packages feed

keiro 0.5.0.0 → 0.6.0.0

raw patch · 49 files changed

+24634/−24925 lines, 49 filesdep ~keikidep ~keiki-codec-jsondep ~keiro-corePVP ok

version bump matches the API change (PVP)

Dependency ranges changed: keiki, keiki-codec-json, keiro-core

API changes (from Hackage documentation)

Files

CHANGELOG.md view
@@ -6,6 +6,20 @@  ## [Unreleased] +## 0.6.0.0 — 2026-07-31++### Breaking Changes++- Requires the exact-`Integer` / total-`Natural` Keiki releases+  (`keiki >=0.6 && <0.7`, `keiki-codec-json >=0.6 && <0.7`), replacing the+  previous `>=0.4 && <0.5` bounds.++### New Features++- Re-exports `Keiro.Codec.Nominal` from `keiro-core`, so generated nominal+  consumer bindings keep a single direct `keiro` dependency alongside the+  existing structural binding re-exports.+ ## 0.5.0.0 — 2026-07-31  No changes this release. Released with the package set for the `keiro-dsl`
bench/Main.hs view
@@ -1,9 +1,9 @@ {-# LANGUAGE BlockArguments #-} {-# LANGUAGE OverloadedRecordDot #-} -module Main (-    main,-)+module Main+  ( main,+  ) where  import Control.Concurrent (threadDelay)@@ -14,24 +14,24 @@ import Data.UUID qualified as UUID import Effectful (Eff, IOE, (:>)) import Effectful.Error.Static (Error)-import Keiro.Inbox (-    InboxDedupePolicy (..),+import Keiro.Inbox+  ( InboxDedupePolicy (..),     InboxPersistence (..),     InboxResult (..),     KafkaDeliveryRef (..),     runInboxTransactionBatch,     runInboxTransactionWith,- )+  ) import Keiro.Integration.Event (IntegrationContentType (..), IntegrationEvent (..))-import Keiro.Outbox (-    OutboxId (..),+import Keiro.Outbox+  ( OutboxId (..),     OutboxRow,     PublishOutcome (..),     countOutboxBacklog,     defaultPublishOptions,     enqueueIntegrationEventTx,     publishClaimedOutbox,- )+  ) import Keiro.Prelude import Keiro.Telemetry qualified as Telemetry import Keiro.Test.Postgres (withFreshStore, withMigratedSuite)@@ -59,247 +59,247 @@ fixedOccurredAt = UTCTime (ModifiedJulianDay 61000) (secondsToDiffTime 0)  data BrokerModel = BrokerModel-    { invocationMicros :: !Int-    , perRecordMicros :: !Int-    }-    deriving stock (Eq, Show)+  { invocationMicros :: !Int,+    perRecordMicros :: !Int+  }+  deriving stock (Eq, Show)  data OutboxScenario = OutboxScenario-    { scenarioName :: !Text-    , brokerModel :: !BrokerModel-    , messages :: ![(OutboxId, IntegrationEvent)]-    }+  { scenarioName :: !Text,+    brokerModel :: !BrokerModel,+    messages :: ![(OutboxId, IntegrationEvent)]+  }  data InboxScenario = InboxScenario-    { inboxScenarioName :: !Text-    , inboxMetrics :: !(Maybe Telemetry.KeiroMetrics)-    , inboxPersistence :: !InboxPersistence-    , inboxBatchSize :: !(Maybe Int)-    , inboxMessages :: ![(IntegrationEvent, KafkaDeliveryRef)]-    }+  { inboxScenarioName :: !Text,+    inboxMetrics :: !(Maybe Telemetry.KeiroMetrics),+    inboxPersistence :: !InboxPersistence,+    inboxBatchSize :: !(Maybe Int),+    inboxMessages :: ![(IntegrationEvent, KafkaDeliveryRef)]+  }  main :: IO () main =-    withMigratedSuite \fixture ->-        withFreshStore fixture \store -> do-            (provider, _env) <--                createMeterProvider-                    emptyMaterializedResources-                    defaultSdkMeterProviderOptions-            meter <- getMeter provider Telemetry.keiroInstrumentationLibrary-            metrics <- Telemetry.newKeiroMetrics meter-            defaultMain (benchmarks store metrics)+  withMigratedSuite \fixture ->+    withFreshStore fixture \store -> do+      (provider, _env) <-+        createMeterProvider+          emptyMaterializedResources+          defaultSdkMeterProviderOptions+      meter <- getMeter provider Telemetry.keiroInstrumentationLibrary+      metrics <- Telemetry.newKeiroMetrics meter+      defaultMain (benchmarks store metrics)  benchmarks :: Store.KirokuStore -> Telemetry.KeiroMetrics -> [Benchmark] benchmarks store metrics =-    [ bgroup-        "outbox"-        [ scenarioBench store hotKey-        , scenarioBench store hotKeyNoLatency-        , scenarioBench store multiKey-        ]-    , bgroup-        "inbox"-        [ inboxScenarioBench store (singleFull metrics)-        , inboxScenarioBench store singleNoMetrics-        , inboxScenarioBench store batch100-        , inboxScenarioBench store singleSlim-        ]-    ]+  [ bgroup+      "outbox"+      [ scenarioBench store hotKey,+        scenarioBench store hotKeyNoLatency,+        scenarioBench store multiKey+      ],+    bgroup+      "inbox"+      [ inboxScenarioBench store (singleFull metrics),+        inboxScenarioBench store singleNoMetrics,+        inboxScenarioBench store batch100,+        inboxScenarioBench store singleSlim+      ]+  ]   where     hotKey =-        OutboxScenario-            { scenarioName = "hot-key"-            , brokerModel = BrokerModel{invocationMicros = 1000, perRecordMicros = 10}-            , messages = scenarioMessages \_ -> Just "aggregate-hot"-            }+      OutboxScenario+        { scenarioName = "hot-key",+          brokerModel = BrokerModel {invocationMicros = 1000, perRecordMicros = 10},+          messages = scenarioMessages \_ -> Just "aggregate-hot"+        }     hotKeyNoLatency =-        OutboxScenario-            { scenarioName = "hot-key-nolatency"-            , brokerModel = BrokerModel{invocationMicros = 0, perRecordMicros = 0}-            , messages = scenarioMessages \_ -> Just "aggregate-hot"-            }+      OutboxScenario+        { scenarioName = "hot-key-nolatency",+          brokerModel = BrokerModel {invocationMicros = 0, perRecordMicros = 0},+          messages = scenarioMessages \_ -> Just "aggregate-hot"+        }     multiKey =-        OutboxScenario-            { scenarioName = "multi-key"-            , brokerModel = BrokerModel{invocationMicros = 1000, perRecordMicros = 10}-            , messages = scenarioMessages \i -> Just ("aggregate-" <> Text.pack (show (i `mod` 200)))-            }+      OutboxScenario+        { scenarioName = "multi-key",+          brokerModel = BrokerModel {invocationMicros = 1000, perRecordMicros = 10},+          messages = scenarioMessages \i -> Just ("aggregate-" <> Text.pack (show (i `mod` 200)))+        }     singleFull metrics' =-        InboxScenario-            { inboxScenarioName = "single-full"-            , inboxMetrics = Just metrics'-            , inboxPersistence = PersistFullEnvelope-            , inboxBatchSize = Nothing-            , inboxMessages = inboxScenarioMessages-            }+      InboxScenario+        { inboxScenarioName = "single-full",+          inboxMetrics = Just metrics',+          inboxPersistence = PersistFullEnvelope,+          inboxBatchSize = Nothing,+          inboxMessages = inboxScenarioMessages+        }     singleNoMetrics =-        InboxScenario-            { inboxScenarioName = "single-nometrics"-            , inboxMetrics = Nothing-            , inboxPersistence = PersistFullEnvelope-            , inboxBatchSize = Nothing-            , inboxMessages = inboxScenarioMessages-            }+      InboxScenario+        { inboxScenarioName = "single-nometrics",+          inboxMetrics = Nothing,+          inboxPersistence = PersistFullEnvelope,+          inboxBatchSize = Nothing,+          inboxMessages = inboxScenarioMessages+        }     batch100 =-        InboxScenario-            { inboxScenarioName = "batch-100"-            , inboxMetrics = Nothing-            , inboxPersistence = PersistFullEnvelope-            , inboxBatchSize = Just 100-            , inboxMessages = inboxScenarioMessages-            }+      InboxScenario+        { inboxScenarioName = "batch-100",+          inboxMetrics = Nothing,+          inboxPersistence = PersistFullEnvelope,+          inboxBatchSize = Just 100,+          inboxMessages = inboxScenarioMessages+        }     singleSlim =-        InboxScenario-            { inboxScenarioName = "single-slim"-            , inboxMetrics = Nothing-            , inboxPersistence = PersistDedupeOnly-            , inboxBatchSize = Nothing-            , inboxMessages = inboxScenarioMessages-            }+      InboxScenario+        { inboxScenarioName = "single-slim",+          inboxMetrics = Nothing,+          inboxPersistence = PersistDedupeOnly,+          inboxBatchSize = Nothing,+          inboxMessages = inboxScenarioMessages+        }  scenarioBench :: Store.KirokuStore -> OutboxScenario -> Benchmark scenarioBench store scenario =-    bench (Text.unpack scenario.scenarioName) $-        nfIO (runScenario store scenario)+  bench (Text.unpack scenario.scenarioName) $+    nfIO (runScenario store scenario)  runScenario :: Store.KirokuStore -> OutboxScenario -> IO () runScenario store scenario = do-    runStoreChecked store do-        Store.runTransaction (Tx.sql "TRUNCATE keiro_outbox")-    seedOutbox store scenario.messages-    runStoreChecked store (drainOutbox scenario.brokerModel 0)+  runStoreChecked store do+    Store.runTransaction (Tx.sql "TRUNCATE keiro_outbox")+  seedOutbox store scenario.messages+  runStoreChecked store (drainOutbox scenario.brokerModel 0)  inboxScenarioBench :: Store.KirokuStore -> InboxScenario -> Benchmark inboxScenarioBench store scenario =-    bench (Text.unpack scenario.inboxScenarioName) $-        nfIO (runInboxScenario store scenario)+  bench (Text.unpack scenario.inboxScenarioName) $+    nfIO (runInboxScenario store scenario)  runInboxScenario :: Store.KirokuStore -> InboxScenario -> IO () runInboxScenario store scenario = do-    runStoreChecked store do-        Store.runTransaction (Tx.sql "TRUNCATE keiro_inbox")-    runStoreChecked store $-        case scenario.inboxBatchSize of-            Nothing ->-                traverse_-                    (processInboxDelivery scenario.inboxMetrics scenario.inboxPersistence)-                    scenario.inboxMessages-            Just batchSize ->-                traverse_-                    (processInboxBatch scenario.inboxMetrics scenario.inboxPersistence)-                    (chunksOf batchSize scenario.inboxMessages)+  runStoreChecked store do+    Store.runTransaction (Tx.sql "TRUNCATE keiro_inbox")+  runStoreChecked store $+    case scenario.inboxBatchSize of+      Nothing ->+        traverse_+          (processInboxDelivery scenario.inboxMetrics scenario.inboxPersistence)+          scenario.inboxMessages+      Just batchSize ->+        traverse_+          (processInboxBatch scenario.inboxMetrics scenario.inboxPersistence)+          (chunksOf batchSize scenario.inboxMessages)  processInboxDelivery ::-    (IOE :> es, Store :> es) =>-    Maybe Telemetry.KeiroMetrics ->-    InboxPersistence ->-    (IntegrationEvent, KafkaDeliveryRef) ->-    Eff es ()+  (IOE :> es, Store :> es) =>+  Maybe Telemetry.KeiroMetrics ->+  InboxPersistence ->+  (IntegrationEvent, KafkaDeliveryRef) ->+  Eff es () processInboxDelivery mMetrics persistence (event, kafkaRef) = do-    result <- runInboxTransactionWith mMetrics persistence PreferIntegrationMessageId event (Just kafkaRef) (\_ -> pure ())-    case result of-        Right (InboxProcessed ()) -> pure ()-        other -> liftIO (fail ("unexpected inbox benchmark result: " <> show other))+  result <- runInboxTransactionWith mMetrics persistence PreferIntegrationMessageId event (Just kafkaRef) (\_ -> pure ())+  case result of+    Right (InboxProcessed ()) -> pure ()+    other -> liftIO (fail ("unexpected inbox benchmark result: " <> show other))  processInboxBatch ::-    (IOE :> es, Store :> es) =>-    Maybe Telemetry.KeiroMetrics ->-    InboxPersistence ->-    [(IntegrationEvent, KafkaDeliveryRef)] ->-    Eff es ()+  (IOE :> es, Store :> es) =>+  Maybe Telemetry.KeiroMetrics ->+  InboxPersistence ->+  [(IntegrationEvent, KafkaDeliveryRef)] ->+  Eff es () processInboxBatch mMetrics persistence chunk = do-    results <--        runInboxTransactionBatch-            mMetrics-            3-            PreferIntegrationMessageId-            persistence-            [(event, Just kafkaRef) | (event, kafkaRef) <- chunk]-            (\_ -> pure ())-    for_ results \case-        Right (InboxProcessed ()) -> pure ()-        other -> liftIO (fail ("unexpected inbox batch benchmark result: " <> show other))+  results <-+    runInboxTransactionBatch+      mMetrics+      3+      PreferIntegrationMessageId+      persistence+      [(event, Just kafkaRef) | (event, kafkaRef) <- chunk]+      (\_ -> pure ())+  for_ results \case+    Right (InboxProcessed ()) -> pure ()+    other -> liftIO (fail ("unexpected inbox batch benchmark result: " <> show other))  seedOutbox :: Store.KirokuStore -> [(OutboxId, IntegrationEvent)] -> IO () seedOutbox store messages =-    traverse_ seedChunk (chunksOf seedChunkSize messages)+  traverse_ seedChunk (chunksOf seedChunkSize messages)   where     seedChunk chunk =-        runStoreChecked store $-            Store.runTransaction $-                traverse_ (uncurry enqueueIntegrationEventTx) chunk+      runStoreChecked store $+        Store.runTransaction $+          traverse_ (uncurry enqueueIntegrationEventTx) chunk  drainOutbox :: (IOE :> es, Store :> es) => BrokerModel -> Int -> Eff es () drainOutbox broker passes = do-    backlog <- countOutboxBacklog-    if backlog == 0-        then pure ()-        else do-            when (passes >= maxDrainPasses) $-                liftIO (fail ("outbox benchmark exceeded safety cap of " <> show maxDrainPasses <> " passes"))-            void (publishClaimedOutbox (simulatedPublish broker) defaultPublishOptions Nothing)-            drainOutbox broker (passes + 1)+  backlog <- countOutboxBacklog+  if backlog == 0+    then pure ()+    else do+      when (passes >= maxDrainPasses) $+        liftIO (fail ("outbox benchmark exceeded safety cap of " <> show maxDrainPasses <> " passes"))+      void (publishClaimedOutbox (simulatedPublish broker) defaultPublishOptions Nothing)+      drainOutbox broker (passes + 1)  simulatedPublish :: (IOE :> es) => BrokerModel -> [OutboxRow] -> Eff es [(OutboxId, PublishOutcome)] simulatedPublish broker rows = do-    let totalMicros = broker.invocationMicros + broker.perRecordMicros * length rows-    when (totalMicros > 0) $-        liftIO (threadDelay totalMicros)-    pure [(row ^. #outboxId, PublishSucceeded) | row <- rows]+  let totalMicros = broker.invocationMicros + broker.perRecordMicros * length rows+  when (totalMicros > 0) $+    liftIO (threadDelay totalMicros)+  pure [(row ^. #outboxId, PublishSucceeded) | row <- rows]  scenarioMessages :: (Int -> Maybe Text) -> [(OutboxId, IntegrationEvent)] scenarioMessages keyFor =-    [ (OutboxId (UUID.fromWords64 0x018f0f1800007000 (0x8000000000000000 + fromIntegral i)), integrationEvent i (keyFor i))-    | i <- [1 .. workloadSize]-    ]+  [ (OutboxId (UUID.fromWords64 0x018f0f1800007000 (0x8000000000000000 + fromIntegral i)), integrationEvent i (keyFor i))+  | i <- [1 .. workloadSize]+  ]  integrationEvent :: Int -> Maybe Text -> IntegrationEvent integrationEvent i key =-    IntegrationEvent-        { messageId = "bench-msg-" <> Text.pack (show i)-        , source = "bench.outbox"-        , destination = "bench.outbox.events.v1"-        , key-        , eventType = "BenchEvent"-        , schemaVersion = 1-        , contentType = ApplicationJson-        , schemaReference = Nothing-        , sourceEventId = Nothing-        , sourceGlobalPosition = Nothing-        , payloadBytes = BS.replicate payloadSize 65-        , occurredAt = fixedOccurredAt-        , causationId = Nothing-        , correlationId = Nothing-        , traceContext = Nothing-        , attributes = Nothing-        }+  IntegrationEvent+    { messageId = "bench-msg-" <> Text.pack (show i),+      source = "bench.outbox",+      destination = "bench.outbox.events.v1",+      key,+      eventType = "BenchEvent",+      schemaVersion = 1,+      contentType = ApplicationJson,+      schemaReference = Nothing,+      sourceEventId = Nothing,+      sourceGlobalPosition = Nothing,+      payloadBytes = BS.replicate payloadSize 65,+      occurredAt = fixedOccurredAt,+      causationId = Nothing,+      correlationId = Nothing,+      traceContext = Nothing,+      attributes = Nothing+    }  inboxScenarioMessages :: [(IntegrationEvent, KafkaDeliveryRef)] inboxScenarioMessages =-    [ ( integrationEvent i (Just ("inbox-key-" <> Text.pack (show i)))-            & #messageId-            .~ ("bench-inbox-msg-" <> Text.pack (show i))-            & #source-            .~ "bench.inbox"-            & #destination-            .~ "bench.inbox.events.v1"-      , KafkaDeliveryRef "bench.inbox.events.v1" 0 (fromIntegral i)-      )-    | i <- [1 .. workloadSize]-    ]+  [ ( integrationEvent i (Just ("inbox-key-" <> Text.pack (show i)))+        & #messageId+        .~ ("bench-inbox-msg-" <> Text.pack (show i))+        & #source+        .~ "bench.inbox"+        & #destination+        .~ "bench.inbox.events.v1",+      KafkaDeliveryRef "bench.inbox.events.v1" 0 (fromIntegral i)+    )+  | i <- [1 .. workloadSize]+  ]  chunksOf :: Int -> [a] -> [[a]] chunksOf n xs-    | n <= 0 = error "chunksOf: non-positive chunk size"-    | otherwise =-        case splitAt n xs of-            ([], _) -> []-            (chunk, rest) -> chunk : chunksOf n rest+  | n <= 0 = error "chunksOf: non-positive chunk size"+  | otherwise =+      case splitAt n xs of+        ([], _) -> []+        (chunk, rest) -> chunk : chunksOf n rest  runStoreChecked :: Store.KirokuStore -> Eff [Store, Error Store.StoreError, IOE] a -> IO a runStoreChecked store action = do-    result <- Store.runStoreIO store action-    case result of-        Left err -> fail (show err)-        Right value -> pure value+  result <- Store.runStoreIO store action+  case result of+    Left err -> fail (show err)+    Right value -> pure value
keiro.cabal view
@@ -1,6 +1,6 @@ cabal-version:   3.0 name:            keiro-version:         0.5.0.0+version:         0.6.0.0 synopsis:        Event sourcing framework and workflow engine description:   A library that composes kiroku, keiki, and shibuya into an@@ -91,6 +91,7 @@     keiro-core:Keiro.Codec,     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,@@ -118,9 +119,9 @@     , hs-opentelemetry-api                   >=1.0      && <1.1     , hs-opentelemetry-propagator-w3c        >=1.0      && <1.1     , hs-opentelemetry-semantic-conventions  >=1.40     && <2-    , keiki                                  >=0.4      && <0.5-    , keiki-codec-json                       >=0.4      && <0.5-    , keiro-core                             ^>=0.5.0.0+    , keiki                                  >=0.6      && <0.7+    , keiki-codec-json                       >=0.6      && <0.7+    , keiro-core                             ^>=0.6.0.0     , kiroku-store                           >=0.3      && <0.4     , lens                                   >=5.2      && <5.4     , mmzk-typeid                            >=0.7      && <0.8@@ -188,7 +189,7 @@     , hs-opentelemetry-api  >=1.0      && <1.1     , hs-opentelemetry-sdk  >=1.0      && <1.1     , keiro-    , keiro-core            ^>=0.5.0.0+    , keiro-core            ^>=0.6.0.0     , keiro-test-support     , kiroku-store          >=0.3      && <0.4     , tasty-bench           >=0.4
src/Keiro.hs view
@@ -1,28 +1,27 @@-{- | Umbrella entry point for the Keiro event-sourcing framework.--Importing @Keiro@ brings the everyday command-side surface into scope in-one go: the command runner ("Keiro.Command"), event 'Codec's-("Keiro.Codec"), the 'EventStream' definition and its snapshot policy-("Keiro.EventStream"), the content-based 'Router' ("Keiro.Router"),-snapshot helpers ("Keiro.Snapshot"), and typed 'Stream' handles-("Keiro.Stream").--The more specialized subsystems are not re-exported here and are imported-directly when needed: read models ("Keiro.ReadModel"), projections-("Keiro.Projection"), process managers ("Keiro.ProcessManager"), the-integration in/outbox ("Keiro.Inbox", "Keiro.Outbox"), timers-("Keiro.Timer"), and telemetry ("Keiro.Telemetry").--Known limit: Keiro currently uses kiroku's PostgreSQL event store, whose append-path serializes all writers through the @$all@ stream row while assigning the-global event order. That makes the global position simple and deterministic,-but it is a throughput ceiling for very high write rates across many unrelated-streams. This production-readiness hardening pass documents the limit rather-than redesigning it; applications that outgrow the single-row global append-lock need a future event-store migration plan.--}-module Keiro (-    -- * Library version+-- | Umbrella entry point for the Keiro event-sourcing framework.+--+-- Importing @Keiro@ brings the everyday command-side surface into scope in+-- one go: the command runner ("Keiro.Command"), event 'Codec's+-- ("Keiro.Codec"), the 'EventStream' definition and its snapshot policy+-- ("Keiro.EventStream"), the content-based 'Router' ("Keiro.Router"),+-- snapshot helpers ("Keiro.Snapshot"), and typed 'Stream' handles+-- ("Keiro.Stream").+--+-- The more specialized subsystems are not re-exported here and are imported+-- directly when needed: read models ("Keiro.ReadModel"), projections+-- ("Keiro.Projection"), process managers ("Keiro.ProcessManager"), the+-- integration in/outbox ("Keiro.Inbox", "Keiro.Outbox"), timers+-- ("Keiro.Timer"), and telemetry ("Keiro.Telemetry").+--+-- Known limit: Keiro currently uses kiroku's PostgreSQL event store, whose append+-- path serializes all writers through the @$all@ stream row while assigning the+-- global event order. That makes the global position simple and deterministic,+-- but it is a throughput ceiling for very high write rates across many unrelated+-- streams. This production-readiness hardening pass documents the limit rather+-- than redesigning it; applications that outgrow the single-row global append+-- lock need a future event-store migration plan.+module Keiro+  ( -- * Library version     version,      -- * Command side@@ -40,7 +39,7 @@     -- * Routing and snapshots     module Keiro.Router,     module Keiro.Snapshot,-)+  ) where  import Keiro.Codec@@ -52,9 +51,8 @@ import Keiro.Snapshot import Keiro.Stream -{- | The Keiro library version, as a 'Text' for display and telemetry.-Keep in lockstep with the @version:@ field in @keiro/keiro.cabal@ when-cutting a release.--}+-- | The Keiro library version, as a 'Text' for display and telemetry.+-- Keep in lockstep with the @version:@ field in @keiro/keiro.cabal@ when+-- cutting a release. version :: Text version = "0.4.0.0"
src/Keiro/Command.hs view
@@ -1,1077 +1,1057 @@-{- | The command side of the framework: hydrate an aggregate, transduce, append.--Running a command against an 'EventStream' follows one pipeline:--1. /Hydrate/ — replay the stream's stored events (optionally fast-forwarding-   from a snapshot) through the keiki transducer to recover the current-   @(state, registers)@ and stream version.-2. /Transduce/ — step the transducer with the command. A rejected transition-   yields 'CommandRejected', while multiple matching transitions yield-   'CommandAmbiguous'; a transition that emits no events yields a no-op-   'CommandResult'.-3. /Append/ — encode the emitted events with the stream's 'Codec' and append-   them at the expected version. An optimistic-concurrency conflict is-   retried up to 'retryLimit' times by rehydrating and replaying; exhausting-   the budget yields 'RetryExhausted'.--Three runners expose this pipeline at increasing levels of integration:--* 'runCommand' — append only.-* 'runCommandWithSql' — run an extra @afterAppend@ action in the /same/-  transaction as the append (e.g. update an inline read model).-* 'runCommandWithSqlEvents' — same, but the callback also receives the-  emitted events paired with their 'RecordedEvent's. This is the primitive-  the projection, process-manager, and router layers build on.--The transactional runners apply Kiroku's configured @enrichEvent@ hook before-event preparation, exactly like 'runCommand'. They therefore require a-'KirokuStoreResource' in the effect stack; install it with @withKirokuStore@-and interpret 'Store' with @runStoreResource@.--Per-stream hydration honors Kiroku's stream-truncation marker. A retained-snapshot must cover every hidden event (snapshot version at least marker minus-one); otherwise hydration fails with 'HydrationGapDetected'. A marker above-the stream head can instead appear as an empty stream and repeated append-conflicts end in 'ConflictFixpoint'. Keiro never truncates streams itself.-Kiroku's @$all@ and category/subscription reads are unaffected by per-stream-truncation: the marker hides events from stream reads rather than deleting-them from the global log.--Every successful append is replayed immediately from its pre-command state so-an unreplayable batch is witnessed at the moment it poisons the stream. The-post-commit witness is counted and attached to the command span without-changing the successful result. The same replay fold feeds transparent-snapshot writes when the stream's 'Keiro.EventStream.SnapshotPolicy' fires;-post-commit snapshot failures are likewise swallowed and counted. Every runner-accepts a tracer for optional OpenTelemetry spans.--The additive hydration primitives are also consumed by "Keiro.ReplayAudit".-The audit deliberately calls the seeded and full variants separately so the-public command-serving fallback cannot hide a stale or unreplayable seed.--}-module Keiro.Command (-    -- * Results and errors-    CommandResult (..),-    CommandError (..),-    HydrationReplayReason (..),-    commandErrorClass,--    -- * Options-    RunCommandOptions (..),-    defaultRunCommandOptions,--    -- * Running commands-    runCommand,-    runCommandWithSql,-    runCommandWithSqlEvents,--    -- * Hydration primitives (replay audit)-    Hydrated (..),-    hydrate,-    hydrateFull,-    hydrateSeeded,-)-where--import Control.Concurrent (threadDelay)-import Control.Exception (displayException)-import Data.Aeson qualified as Aeson-import Data.ByteString.Lazy.Char8 qualified as LazyByteString-import Data.Functor (($>))-import Data.Int (Int32)-import Data.Text qualified as Text-import Effectful (Eff, IOE, (:>))-import Effectful.Concurrent (runConcurrent)-import Effectful.Concurrent.Async qualified as Async-import Effectful.Error.Static (Error, tryError)-import Effectful.Exception (trySync)-import GHC.Clock (getMonotonicTimeNSec)-import GHC.Stack (HasCallStack)-import Keiki.Core (BoolAlg, RegFile)-import Keiki.Core qualified as Keiki-import Keiro.Codec (Codec, CodecError, decodeRecorded, encodeForAppendWithMetadata)-import Keiro.EventStream (EventStream, StateCodec, Terminality (..))-import Keiro.EventStream.Validate (ValidatedEventStream, unvalidated)-import Keiro.Prelude-import Keiro.ReplayDigest (canonicalJsonBytes, replayDigest)-import Keiro.Snapshot (-    SnapshotLookup (..),-    SnapshotMissReason (..),-    SnapshotSeed,-    encodeSnapshotStrict,-    lookupSnapshotSeed,-    writeSnapshotEncoded,- )-import Keiro.Snapshot.Policy (shouldSnapshotSpan)-import Keiro.Stream (Stream)-import Keiro.Telemetry (-    KeiroMetrics,-    keiro_events_appended,-    keiro_replay_divergence,-    keiro_retry_attempt,-    recordCommandConflicts,-    recordCommandDuplicates,-    recordCommandRetries,-    recordSnapshotApplyDivergence,-    recordSnapshotDecodeFailures,-    recordSnapshotEncodeFailures,-    recordSnapshotReadHits,-    recordSnapshotReadMisses,-    recordSnapshotSeedDivergence,-    recordSnapshotWriteFailures,-    withCommandSpan,- )-import Kiroku.Store.Append (appendToStream)-import Kiroku.Store.Effect (Store)-import Kiroku.Store.Effect.Resource (KirokuStoreResource, getKirokuStore)-import Kiroku.Store.Error (StoreError (..))-import Kiroku.Store.Read (readStreamForwardStream)-import Kiroku.Store.Transaction (-    PreparedEvent,-    appendConflictToStoreError,-    appendToStreamTx,-    enrichEventsIO,-    prepareEventsIO,-    runTransaction,- )-import Kiroku.Store.Types (-    AppendResult,-    EventData,-    EventId (..),-    ExpectedVersion (..),-    GlobalPosition (..),-    RecordedEvent (..),-    StreamName (..),-    StreamVersion (..),- )-import OpenTelemetry.Attributes.Key (unkey)-import OpenTelemetry.SemanticConventions (db_system_name, error_type)-import OpenTelemetry.Trace.Core (Span, SpanStatus (..), Tracer, addAttribute, setStatus)-import Streamly.Data.Fold qualified as Fold-import Streamly.Data.Stream qualified as Streamly-import System.IO (stderr)-import System.Random.Stateful (globalStdGen, uniformRM)-import "hasql-transaction" Hasql.Transaction qualified as Tx-import Prelude qualified--{- | The outcome of a successfully handled command.--Reports the target 'Stream', the stream version after the command, the global-log position only when this command appended and the store assigned a real-one, and how many events were appended. A no-op reports @0@ events and-@Nothing@ for its global position because per-stream reads cannot recover a-true global position.--}-data CommandResult target = CommandResult-    { target :: !(Stream target)-    , streamVersion :: !StreamVersion-    , globalPosition :: !(Maybe GlobalPosition)-    -- ^ 'Just' only when this command appended; 'Nothing' for a no-op.-    , eventsAppended :: !Int-    }-    deriving stock (Generic, Eq, Show)---- | Why a command did not complete.-data CommandError-    = -- | A stored event could not be decoded while rehydrating the aggregate.-      HydrationDecodeFailed !CodecError-    | {- | Replay of the stored events through the transducer stalled. The-      version identifies the failing stored event; for-      'HydrationTruncatedChain' it identifies the last stored event, after-      which the expected multi-event chain remained incomplete.-      -}-      HydrationReplayFailed !StreamVersion !HydrationReplayReason-    | {- | Hydration observed a non-contiguous stream version. Carries the-      expected version followed by the observed version. The store writes-      contiguous versions, so this indicates that stream truncation hid-      events not covered by the hydration seed. Restore visibility with-      @clearStreamTruncateBefore@ or provide a covering snapshot before-      retrying the command.-      -}-      HydrationGapDetected !StreamVersion !StreamVersion-    | -- | No transducer edge matched the command in the hydrated state.-      CommandRejected-    | {- | Two or more transducer edges matched the command in the hydrated-      state. This is a deterministic aggregate-definition bug rather than a-      business rejection; the list contains the zero-based matched edge-      indices in declaration order.-      -}-      CommandAmbiguous ![Int]-    | -- | An emitted event could not be encoded for append.-      EncodeFailed !CodecError-    | -- | The underlying store rejected the append.-      StoreFailed !StoreError-    | {- | Optimistic-concurrency retries were exhausted (carries the total-      attempts made and the last store error).-      -}-      RetryExhausted !Int !StoreError-    | {- | Retrying after a 'StreamAlreadyExists' conflict re-observed the same-      stream version: the store says the stream exists but reading it shows no-      progress. The typical cause is a soft-deleted stream, where reads return-      nothing but appends still collide. Carries the observed version and the-      conflict.-      -}-      ConflictFixpoint !StreamVersion !StoreError-    deriving stock (Generic, Eq, Show)--{- | Why replay of stored events stalled, projected from keiki's structured-failure types onto a monomorphic vocabulary suitable for 'CommandError'.--}-data HydrationReplayReason-    = -- | No edge's first output template could have produced the event.-      HydrationNoInvertingEdge-    | -- | More than one edge could have produced the event.-      HydrationAmbiguousInversion-    | -- | An event did not match the next expected event in a chain.-      HydrationQueueMismatch-    | -- | The stream ended in the middle of a multi-event chain.-      HydrationTruncatedChain-    deriving stock (Generic, Eq, Show)--{- | Knobs controlling a single command invocation.--* 'retryLimit' — how many times to rehydrate-and-replay after an-  optimistic-concurrency conflict before giving up with 'RetryExhausted'.-* 'pageSize' — batch size when reading the stream during hydration.-* 'eventIds' — caller-supplied ids assigned to the emitted events in order;-  the basis for deterministic, idempotent appends (see 'Keiro.Router' and-  'Keiro.ProcessManager').-* 'beforeAppend' — a hook run immediately before each append attempt,-  primarily a test seam for injecting concurrent writes.-* 'retryBackoffMicros' — base delay before the k-th OCC retry, capped at-  100 ms and jittered. Set to 0 to disable backoff.-* 'metrics' — optional metrics handle for command and snapshot counters.-* 'verifyReplayOnAppend' — replay every just-appended batch from the-  pre-command state. Divergence is a post-commit advisory: it is counted and-  attached to the command span, but the already-successful command still-  succeeds. Snapshot-enabled streams always run the fold because snapshots-  consume its result.-* 'seedVerifySampleRate' — verify one in N snapshot seeds against a full-  replay through the seed version. The replay runs asynchronously and never-  blocks or fails the command. This detects hand-written fold changes that-  leave the snapshot discriminator unchanged; @0@ disables the witness.--}-data RunCommandOptions = RunCommandOptions-    { retryLimit :: !Int-    , pageSize :: !Int32-    , eventIds :: ![EventId]-    , beforeAppend :: !(IO ())-    , retryBackoffMicros :: !Int-    , metrics :: !(Maybe KeiroMetrics)-    , verifyReplayOnAppend :: !Bool-    , seedVerifySampleRate :: !Int-    , tracer :: !(Maybe Tracer)-    {- ^ Optional OpenTelemetry tracer. When 'Just', the command runner-    opens an 'Internal'-kind span around each invocation, named after-    the resolved stream identifier and decorated with the messaging /-    error semantic-conventions attributes audited in-    'docs/research/opentelemetry-semconv-audit.md'. When 'Nothing',-    the runner emits no spans.-    -}-    , metadata :: !(Maybe Value)-    {- ^ Optional JSON merged into every event's metadata for this command-    invocation. Carries ambient context such as actor type, agent id,-    and session id. The codec always adds a @schemaVersion@ key; the-    keys here are merged on top (see 'Keiro.Codec.metadataFor'). When-    'Nothing', events carry only the schema-version marker, exactly as-    before this field existed.-    -}-    }-    deriving stock (Generic)--{- | Sensible defaults: 3 retries, 256-event read pages, no caller-assigned-event ids, a no-op pre-append hook, 5ms retry backoff, no metrics, post-append-replay verification enabled, one sampled snapshot-seed verification per 1000-snapshot hits, no tracer, and no extra metadata.--}-defaultRunCommandOptions :: RunCommandOptions-defaultRunCommandOptions =-    RunCommandOptions-        { retryLimit = 3-        , pageSize = 256-        , eventIds = []-        , beforeAppend = pure ()-        , retryBackoffMicros = 5000-        , metrics = Nothing-        , verifyReplayOnAppend = True-        , seedVerifySampleRate = 1000-        , tracer = Nothing-        , metadata = Nothing-        }--data Hydrated rs s = Hydrated-    { state :: !s-    , registers :: !(RegFile rs)-    , streamVersion :: !StreamVersion-    }-    deriving stock (Generic)--data CommandPlan target rs s co-    = CommandNoOp !(CommandResult target)-    | CommandAppend !(Hydrated rs s) ![co] ![EventData]-    deriving stock (Generic)--hydrate ::-    forall phi rs s ci co es.-    (HasCallStack, IOE :> es, Store :> es, BoolAlg phi (RegFile rs, ci), Eq co) =>-    RunCommandOptions ->-    EventStream phi rs s ci co ->-    Stream (EventStream phi rs s ci co) ->-    Eff es (Either CommandError (Hydrated rs s))-hydrate options eventStream targetStream =-    snapshotSeed >>= \case-        Nothing -> hydrateFull options eventStream targetStream-        Just seed -> do-            replayed <--                hydrateSeeded-                    options-                    eventStream-                    targetStream-                    (seed ^. #state)-                    (seed ^. #registers)-                    (seed ^. #streamVersion)-            case replayed of-                Left _ -> hydrateFull options eventStream targetStream-                Right hydrated -> do-                    for_ (eventStream ^. #stateCodec) $ \codec ->-                        scheduleSeedVerification options eventStream targetStream codec seed-                    pure (Right hydrated)-  where-    snapshotSeed =-        case eventStream ^. #stateCodec of-            Nothing -> pure Nothing-            Just codec -> do-                lookupSnapshotSeed ((eventStream ^. #resolveStreamName) targetStream) codec >>= \case-                    SnapshotHit seed -> do-                        recordSnapshotReadHits (options ^. #metrics) 1-                        pure (Just seed)-                    SnapshotUnavailable reason -> do-                        recordSnapshotReadMisses (options ^. #metrics) 1-                        case reason of-                            SnapshotDecodeFailed _ -> recordSnapshotDecodeFailures (options ^. #metrics) 1-                            _ -> pure ()-                        pure Nothing--hydrateFull ::-    forall phi rs s ci co es.-    (HasCallStack, Store :> es, BoolAlg phi (RegFile rs, ci), Eq co) =>-    RunCommandOptions ->-    EventStream phi rs s ci co ->-    Stream (EventStream phi rs s ci co) ->-    Eff es (Either CommandError (Hydrated rs s))-hydrateFull options eventStream targetStream =-    hydrateSeeded-        options-        eventStream-        targetStream-        (eventStream ^. #initialState)-        (eventStream ^. #initialRegisters)-        (StreamVersion 0)--{- | Replay a stored stream from an arbitrary snapshot or initial-state seed.--The store stream is grouped into bounded lists and each decoded prefix is-handed to keiki's 'Keiki.replayEvents'. Decoding stops at the first bad event in-a group, but the valid prefix is replayed first so an earlier replay failure-retains precedence over a later codec failure.--}-hydrateSeeded ::-    forall phi rs s ci co es.-    (HasCallStack, Store :> es, BoolAlg phi (RegFile rs, ci), Eq co) =>-    RunCommandOptions ->-    EventStream phi rs s ci co ->-    Stream (EventStream phi rs s ci co) ->-    s ->-    RegFile rs ->-    StreamVersion ->-    Eff es (Either CommandError (Hydrated rs s))-hydrateSeeded options eventStream targetStream seedState seedRegisters seedVersion = do-    hydrateSeededThrough-        Nothing-        options-        eventStream-        targetStream-        seedState-        seedRegisters-        seedVersion--hydrateSeededThrough ::-    forall phi rs s ci co es.-    (HasCallStack, Store :> es, BoolAlg phi (RegFile rs, ci), Eq co) =>-    Maybe StreamVersion ->-    RunCommandOptions ->-    EventStream phi rs s ci co ->-    Stream (EventStream phi rs s ci co) ->-    s ->-    RegFile rs ->-    StreamVersion ->-    Eff es (Either CommandError (Hydrated rs s))-hydrateSeededThrough replayThrough options eventStream targetStream seedState seedRegisters seedVersion = do-    replayed <--        Streamly.fold-            (Fold.foldlM' replayPage (pure (Right initialReplay)))-            recordedPages-    pure (finishReplay replayed)-  where-    readPageSize = Prelude.max 1 (options ^. #pageSize)-    groupSize = Prelude.fromIntegral readPageSize-    recordedPages =-        Streamly.foldMany-            (Fold.take groupSize Fold.toList)-            boundedRecorded-    boundedRecorded =-        case replayThrough of-            Nothing -> readStreamForwardStream resolvedName seedVersion readPageSize-            Just endVersion ->-                Streamly.takeWhile-                    (\recorded -> recorded ^. #streamVersion <= endVersion)-                    (readStreamForwardStream resolvedName seedVersion readPageSize)-    resolvedName = (eventStream ^. #resolveStreamName) targetStream-    initialReplay = (Keiki.Settled seedState, seedRegisters, Nothing)--    replayPage ::-        Either CommandError (Keiki.InFlight s co, RegFile rs, Maybe RecordedEvent) ->-        [RecordedEvent] ->-        Eff es (Either CommandError (Keiki.InFlight s co, RegFile rs, Maybe RecordedEvent))-    replayPage (Left err) _ = pure (Left err)-    replayPage (Right (wrapper, registers, previousRecorded)) page =-        pure $ case Keiki.replayEvents (eventStream ^. #transducer) (wrapper, registers) decodedEvents of-            Left replayFailure ->-                Left (hydrationReplayError previousRecorded decodedRecorded replayFailure)-            Right (nextWrapper, nextRegisters) ->-                case pendingInputFailure of-                    Just err -> Left err-                    Nothing ->-                        Right-                            ( nextWrapper-                            , nextRegisters-                            , latestRecorded decodedRecorded previousRecorded-                            )-      where-        (decodedRecorded, decodedEvents, pendingInputFailure) = decodePrefix previousRecorded page--    decodePrefix :: Maybe RecordedEvent -> [RecordedEvent] -> ([RecordedEvent], [co], Maybe CommandError)-    decodePrefix previousRecorded = go [] [] startingVersion-      where-        startingVersion = maybe seedVersion (^. #streamVersion) previousRecorded--        go recordedAcc eventAcc lastSeen = \case-            [] -> (Prelude.reverse recordedAcc, Prelude.reverse eventAcc, Nothing)-            recorded : rest ->-                let observed = recorded ^. #streamVersion-                    expected = nextStreamVersion lastSeen-                 in if observed /= expected-                        then-                            ( Prelude.reverse recordedAcc-                            , Prelude.reverse eventAcc-                            , Just (HydrationGapDetected expected observed)-                            )-                        else case decodeRecorded (eventStream ^. #eventCodec) recorded of-                            Left err ->-                                ( Prelude.reverse recordedAcc-                                , Prelude.reverse eventAcc-                                , Just (HydrationDecodeFailed err)-                                )-                            Right event ->-                                go (recorded : recordedAcc) (event : eventAcc) observed rest--        nextStreamVersion (StreamVersion version) = StreamVersion (version Prelude.+ 1)--    hydrationReplayError ::-        Maybe RecordedEvent ->-        [RecordedEvent] ->-        Keiki.ReplayFailure s co ->-        CommandError-    hydrationReplayError previousRecorded decodedRecorded replayFailure =-        HydrationReplayFailed failureVersion (toHydrationReason (Keiki.replayFailureReason replayFailure))-      where-        failureVersion =-            maybe seedVersion (^. #streamVersion) failureRecorded-        failureRecorded =-            case Keiki.replayFailureReason replayFailure of-                Keiki.ReplayLogTruncated{} -> latestRecorded decodedRecorded previousRecorded-                Keiki.ReplayEventFailed{} ->-                    case recordedAt (Keiki.replayFailedIndex replayFailure) decodedRecorded of-                        Just recorded -> Just recorded-                        Nothing -> latestRecorded decodedRecorded previousRecorded--    finishReplay = \case-        Left err -> Left err-        Right (wrapper, finalRegisters, lastRecorded) ->-            case wrapper of-                Keiki.Settled finalState ->-                    Right-                        Hydrated-                            { state = finalState-                            , registers = finalRegisters-                            , streamVersion = maybe seedVersion (^. #streamVersion) lastRecorded-                            }-                Keiki.InFlight{} ->-                    Left-                        ( HydrationReplayFailed-                            (maybe seedVersion (^. #streamVersion) lastRecorded)-                            HydrationTruncatedChain-                        )--    toHydrationReason = \case-        Keiki.ReplayEventFailed stepFailure -> case stepFailure of-            Keiki.ReplayNoInvertingEdge{} -> HydrationNoInvertingEdge-            Keiki.ReplayAmbiguousInversions{} -> HydrationAmbiguousInversion-            Keiki.ReplayQueueMismatch{} -> HydrationQueueMismatch-        Keiki.ReplayLogTruncated{} -> HydrationTruncatedChain--    latestRecorded recorded fallback =-        case lastMaybe recorded of-            Just latest -> Just latest-            Nothing -> fallback--    lastMaybe = \case-        [] -> Nothing-        first : rest -> Just (Prelude.foldl (\_ current -> current) first rest)--    recordedAt eventIndex recorded =-        case Prelude.drop eventIndex recorded of-            found : _ -> Just found-            [] -> Nothing--scheduleSeedVerification ::-    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) ->-    StateCodec (s, RegFile rs) ->-    SnapshotSeed rs s ->-    Eff es ()-scheduleSeedVerification options eventStream targetStream codec seed = do-    void $ trySync $ do-        sampled <--            case options ^. #seedVerifySampleRate of-                rate | rate <= 0 -> pure False-                1 -> pure True-                rate -> liftIO ((== (1 :: Int)) <$> uniformRM (1, rate) globalStdGen)-        when sampled-            $ void-            $ runConcurrent-            $ Async.async-            $ verifySnapshotSeed options eventStream targetStream codec seed--verifySnapshotSeed ::-    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) ->-    StateCodec (s, RegFile rs) ->-    SnapshotSeed rs s ->-    Eff es ()-verifySnapshotSeed options eventStream targetStream codec seed = do-    let seedVersion = seed ^. #streamVersion-        streamName = (eventStream ^. #resolveStreamName) targetStream-    full <--        hydrateSeededThrough-            (Just seedVersion)-            options-            eventStream-            targetStream-            (eventStream ^. #initialState)-            (eventStream ^. #initialRegisters)-            (StreamVersion 0)-    seededEncoded <--        liftIO-            $ encodeSnapshotStrict-                codec-                (seed ^. #state, seed ^. #registers)-    case (seededEncoded, full) of-        (Left seedEncodeError, _) ->-            reportSeedDivergence-                options-                streamName-                seedVersion-                ("encode-failed:" <> Text.pack (displayException seedEncodeError))-                (case full of Left replayError -> "replay-failed:" <> Text.pack (show replayError); Right _ -> "not-compared:seed-encode-failed")-        (Right seededValue, Left replayError) ->-            reportSeedDivergence-                options-                streamName-                seedVersion-                (replayDigest seededValue)-                ("replay-failed:" <> Text.pack (show replayError))-        (Right seededValue, Right fullHydrated)-            | fullHydrated ^. #streamVersion /= seedVersion ->-                reportSeedDivergence-                    options-                    streamName-                    seedVersion-                    (replayDigest seededValue)-                    ("version-mismatch:" <> Text.pack (show (fullHydrated ^. #streamVersion)))-            | otherwise -> do-                fullEncoded <--                    liftIO-                        $ encodeSnapshotStrict-                            codec-                            (fullHydrated ^. #state, fullHydrated ^. #registers)-                case fullEncoded of-                    Left fullEncodeError ->-                        reportSeedDivergence-                            options-                            streamName-                            seedVersion-                            (replayDigest seededValue)-                            ("encode-failed:" <> Text.pack (displayException fullEncodeError))-                    Right fullValue ->-                        unless-                            (canonicalJsonBytes seededValue == canonicalJsonBytes fullValue)-                            ( reportSeedDivergence-                                options-                                streamName-                                seedVersion-                                (replayDigest seededValue)-                                (replayDigest fullValue)-                            )--reportSeedDivergence ::-    (IOE :> es) =>-    RunCommandOptions ->-    StreamName ->-    StreamVersion ->-    Text ->-    Text ->-    Eff es ()-reportSeedDivergence options (StreamName streamName) (StreamVersion seedVersion) seededDigest fullDigest = do-    recordSnapshotSeedDivergence (options ^. #metrics) 1-    liftIO-        $ LazyByteString.hPutStrLn stderr-        $ Aeson.encode-        $ Aeson.object-            [ "event" Aeson..= ("keiro.snapshot.seed.divergence" :: Text)-            , "level" Aeson..= ("error" :: Text)-            , "stream" Aeson..= streamName-            , "seedVersion" Aeson..= seedVersion-            , "seededDigest" Aeson..= seededDigest-            , "fullDigest" Aeson..= fullDigest-            ]--{- | Hydrate the target stream, transduce the command, and append any emitted-events. Retries optimistic-concurrency conflicts up to 'retryLimit'. This-is the plain runner with no in-transaction side effects.--}-runCommand ::-    forall phi rs s ci co es.-    (HasCallStack, IOE :> es, Store :> es, Error StoreError :> es, BoolAlg phi (RegFile rs, ci), Eq co) =>-    RunCommandOptions ->-    ValidatedEventStream phi rs s ci co ->-    Stream (EventStream phi rs s ci co) ->-    ci ->-    Eff es (Either CommandError (CommandResult (EventStream phi rs s ci co)))-runCommand options validatedEventStream targetStream command =-    withCommandSpan (options ^. #tracer) (resolvedStreamName eventStream targetStream) Nothing $ \mSpan -> do-        (result, attemptNo) <- attempt mSpan 1 Nothing-        recordCommandOutcome mSpan (^. #eventsAppended) attemptNo result-        pure result-  where-    eventStream = unvalidated validatedEventStream--    attempt mSpan attemptNo lastConflict = do-        hydrated <- hydrate options eventStream targetStream-        either (\err -> pure (Left err, attemptNo)) (runPlan mSpan attemptNo lastConflict) hydrated--    runPlan mSpan attemptNo lastConflict current =-        case conflictFixpoint lastConflict (current ^. #streamVersion) of-            Just err -> pure (Left err, attemptNo)-            Nothing ->-                case prepareCommandPlan options eventStream targetStream current command of-                    Left err -> pure (Left err, attemptNo)-                    Right (CommandNoOp result) -> pure (Right result, attemptNo)-                    Right (CommandAppend current' events encoded) ->-                        appendOnce mSpan attemptNo current' events encoded--    appendOnce mSpan attemptNo current events encoded = do-        liftIO (options ^. #beforeAppend)-        appended <--            tryError @StoreError-                $ appendToStream-                    ((eventStream ^. #resolveStreamName) targetStream)-                    (expectedVersion (current ^. #streamVersion))-                    encoded-        case appended of-            Right appendResult -> do-                verifyAndSnapshot options mSpan eventStream current events appendResult-                pure (Right (appendedResult targetStream appendResult (Prelude.length encoded)), attemptNo)-            Left (_, storeError) ->-                retryOrFail options (attempt mSpan) attemptNo (current ^. #streamVersion) storeError--{- | Like 'runCommand', but run @afterAppend@ inside the /same/ transaction-as the append, so a read-model write commits atomically with the events.-The callback's result is returned as @Just@ on append (and 'Nothing' for a-no-op command that appended nothing).--Requires 'KirokuStoreResource' so the transactional append applies the-configured @enrichEvent@ hook. See 'runCommandWithSqlEvents' for the callback's-locking and latency implications.--}-runCommandWithSql ::-    forall phi rs s ci co a es.-    (HasCallStack, IOE :> es, Store :> es, Error StoreError :> es, KirokuStoreResource :> es, BoolAlg phi (RegFile rs, ci), Eq co) =>-    RunCommandOptions ->-    ValidatedEventStream phi rs s ci co ->-    Stream (EventStream phi rs s ci co) ->-    ci ->-    (AppendResult -> Tx.Transaction a) ->-    Eff es (Either CommandError (CommandResult (EventStream phi rs s ci co), Maybe a))-runCommandWithSql options eventStream targetStream command afterAppend =-    runCommandWithSqlEvents options eventStream targetStream command (\_ appendResult -> afterAppend appendResult)--{- | The most general runner: like 'runCommandWithSql', but the-in-transaction callback also receives every emitted event paired with the-'RecordedEvent' the store persisted for it, in append order. Inline-projections, process managers, and routers are all built on this.--The runner requires 'KirokuStoreResource' and applies the configured-@enrichEvent@ hook before preparing the append. The callback therefore sees-the enriched metadata that was persisted.--The append updates Kiroku's global @$all@ stream and holds its PostgreSQL row-lock until this transaction commits. Every SQL operation in the callback-therefore extends the store-wide append serialization window. Keep the-callback small: precompute outside the transaction where possible, batch-writes, and minimize database round trips.--}-runCommandWithSqlEvents ::-    forall phi rs s ci co a es.-    (HasCallStack, IOE :> es, Store :> es, Error StoreError :> es, KirokuStoreResource :> es, BoolAlg phi (RegFile rs, ci), Eq co) =>-    RunCommandOptions ->-    ValidatedEventStream phi rs s ci co ->-    Stream (EventStream phi rs s ci co) ->-    ci ->-    ([(co, RecordedEvent)] -> AppendResult -> Tx.Transaction a) ->-    Eff es (Either CommandError (CommandResult (EventStream phi rs s ci co), Maybe a))-runCommandWithSqlEvents options validatedEventStream targetStream command afterAppend =-    withCommandSpan (options ^. #tracer) (resolvedStreamName eventStream targetStream) Nothing $ \mSpan -> do-        (result, attemptNo) <- attempt mSpan 1 Nothing-        recordCommandOutcome mSpan (\(r, _) -> r ^. #eventsAppended) attemptNo result-        pure result-  where-    eventStream = unvalidated validatedEventStream--    attempt mSpan attemptNo lastConflict = do-        hydrated <- hydrate options eventStream targetStream-        either (\err -> pure (Left err, attemptNo)) (runPlan mSpan attemptNo lastConflict) hydrated--    runPlan mSpan attemptNo lastConflict current =-        case conflictFixpoint lastConflict (current ^. #streamVersion) of-            Just err -> pure (Left err, attemptNo)-            Nothing ->-                case prepareCommandPlan options eventStream targetStream current command of-                    Left err -> pure (Left err, attemptNo)-                    Right (CommandNoOp result) -> pure (Right (result, Nothing), attemptNo)-                    Right (CommandAppend current' events encoded) ->-                        appendWithSqlOnce mSpan attemptNo current' events encoded--    appendWithSqlOnce mSpan attemptNo current events encoded = do-        liftIO (options ^. #beforeAppend)-        store <- getKirokuStore-        enriched <- liftIO (enrichEventsIO store encoded)-        prepared <- prepareEventsIO enriched-        now <- liftIO getCurrentTime-        let streamName = (eventStream ^. #resolveStreamName) targetStream-            expected = expectedVersion (current ^. #streamVersion)-            body = do-                appended <- appendToStreamTx streamName expected prepared now-                case appended of-                    Left conflict ->-                        Tx.condemn $> Left (appendConflictToStoreError conflict)-                    Right appendResult -> do-                        let recordeds = reconstructRecorded appendResult now prepared-                        userValue <- afterAppend (Prelude.zip events recordeds) appendResult-                        pure (Right (appendResult, userValue))-        outcome <- tryError @StoreError (runTransaction body)-        case outcome of-            Right (Right (appendResult, userValue)) -> do-                verifyAndSnapshot options mSpan eventStream current events appendResult-                pure (Right (appendedResult targetStream appendResult (Prelude.length encoded), Just userValue), attemptNo)-            Right (Left storeError) ->-                retryOrFail options (attempt mSpan) attemptNo (current ^. #streamVersion) storeError-            Left (_, storeError) ->-                retryOrFail options (attempt mSpan) attemptNo (current ^. #streamVersion) storeError--prepareCommandPlan ::-    (BoolAlg phi (RegFile rs, ci)) =>-    RunCommandOptions ->-    EventStream phi rs s ci co ->-    Stream (EventStream phi rs s ci co) ->-    Hydrated rs s ->-    ci ->-    Either CommandError (CommandPlan (EventStream phi rs s ci co) rs s co)-prepareCommandPlan options eventStream targetStream current command =-    case evaluateCommand eventStream current command of-        Left err -> Left err-        Right events -> toPlan events-  where-    toPlan [] =-        Right (CommandNoOp (noOpResult targetStream current))-    toPlan events =-        CommandAppend current events-            . assignEventIds (options ^. #eventIds)-            <$> encodeEvents (eventStream ^. #eventCodec) (options ^. #metadata) events--{- | Render the stream that the command targets as plain 'Text', for use-as a span name.--}-resolvedStreamName ::-    EventStream phi rs s ci co ->-    Stream (EventStream phi rs s ci co) ->-    Text-resolvedStreamName eventStream targetStream =-    case (eventStream ^. #resolveStreamName) targetStream of-        StreamName n -> n--{- | Attach the command-span outcome attributes after the runner returns.--On success: 'db.system.name' and 'keiro.events.appended'.-On failure: 'error.type' (low-cardinality classifier) and span status-'Error' (carrying the rendered 'CommandError' as the description).--Pure no-op when no span is active ('Nothing' tracer, etc).--}-recordCommandOutcome ::-    (IOE :> es) =>-    Maybe Span ->-    (a -> Int) ->-    Int ->-    Either CommandError a ->-    Eff es ()-recordCommandOutcome Nothing _ _ _ = pure ()-recordCommandOutcome (Just sp) eventsOf attemptNo result = do-    addAttribute sp (unkey db_system_name) ("postgresql" :: Text)-    addAttribute sp (unkey keiro_retry_attempt) (Prelude.fromIntegral attemptNo :: Int64)-    case result of-        Right v ->-            addAttribute sp (unkey keiro_events_appended) (Prelude.fromIntegral (eventsOf v) :: Int64)-        Left err -> do-            addAttribute sp (unkey error_type) (commandErrorClass err)-            setStatus sp (Error (Text.take 256 (Text.pack (show err))))--{- | Low-cardinality classifier for a 'CommandError'. Used as the-@error.type@ attribute value on the command span.--}-commandErrorClass :: CommandError -> Text-commandErrorClass = \case-    HydrationDecodeFailed{} -> "hydration_decode_failed"-    HydrationReplayFailed _ HydrationNoInvertingEdge -> "hydration_replay_no_inverting_edge"-    HydrationReplayFailed _ HydrationAmbiguousInversion -> "hydration_replay_ambiguous_inversion"-    HydrationReplayFailed _ HydrationQueueMismatch -> "hydration_replay_queue_mismatch"-    HydrationReplayFailed _ HydrationTruncatedChain -> "hydration_replay_truncated_chain"-    HydrationGapDetected{} -> "hydration_gap_detected"-    CommandRejected -> "command_rejected"-    CommandAmbiguous{} -> "command_ambiguous"-    EncodeFailed{} -> "encode_failed"-    StoreFailed{} -> "store_failed"-    RetryExhausted{} -> "retry_exhausted"-    ConflictFixpoint{} -> "conflict_fixpoint"--verifyAndSnapshot ::-    forall phi rs s ci co es.-    (BoolAlg phi (RegFile rs, ci), IOE :> es, Store :> es, Error StoreError :> es, Eq co) =>-    RunCommandOptions ->-    Maybe Span ->-    EventStream phi rs s ci co ->-    Hydrated rs s ->-    [co] ->-    AppendResult ->-    Eff es ()-verifyAndSnapshot options mSpan eventStream current events appendResult-    | Prelude.not (options ^. #verifyReplayOnAppend)-    , Nothing <- eventStream ^. #stateCodec =-        pure ()-    | otherwise =-        case Keiki.applyEventsEither (eventStream ^. #transducer) (state current, registers current) events of-            Left failure -> do-                recordSnapshotApplyDivergence (options ^. #metrics) 1-                for_ mSpan $ \sp ->-                    addAttribute-                        sp-                        (unkey keiro_replay_divergence)-                        (Text.take 256 (renderReplayFailure failure))-            Right finalState ->-                case eventStream ^. #stateCodec of-                    Nothing -> pure ()-                    Just codec -> do-                        let finalVersion = appendResult ^. #streamVersion-                            terminality =-                                if Keiki.isFinal (eventStream ^. #transducer) (Prelude.fst finalState)-                                    then Terminal-                                    else NotTerminal-                        when (shouldSnapshotSpan (eventStream ^. #snapshotPolicy) terminality finalState (current ^. #streamVersion) finalVersion)-                            $ do-                                encoded <- liftIO (encodeSnapshotStrict codec finalState)-                                case encoded of-                                    Left _ -> recordSnapshotEncodeFailures (options ^. #metrics) 1-                                    Right value -> do-                                        outcome <- tryError @StoreError (writeSnapshotEncoded (appendResult ^. #streamId) finalVersion codec value)-                                        case outcome of-                                            Right () -> pure ()-                                            Left _ -> recordSnapshotWriteFailures (options ^. #metrics) 1--renderReplayFailure :: Keiki.ReplayFailure s co -> Text-renderReplayFailure failure =-    "event_index="-        <> Text.pack (show (Keiki.replayFailedIndex failure))-        <> ";reason="-        <> case Keiki.replayFailureReason failure of-            Keiki.ReplayEventFailed stepFailure -> case stepFailure of-                Keiki.ReplayNoInvertingEdge{} -> "no_inverting_edge"-                Keiki.ReplayAmbiguousInversions{} -> "ambiguous_inversions"-                Keiki.ReplayQueueMismatch{} -> "queue_mismatch"-            Keiki.ReplayLogTruncated{} -> "log_truncated"--retryOrFail ::-    (IOE :> es) =>-    RunCommandOptions ->-    (Int -> Maybe (StoreError, StreamVersion) -> Eff es (Either CommandError a, Int)) ->-    Int ->-    StreamVersion ->-    StoreError ->-    Eff es (Either CommandError a, Int)-retryOrFail options retry attemptNo observedVersion storeError-    | isRetryableConflict storeError-    , attemptNo <= options ^. #retryLimit = do-        recordCommandConflicts (options ^. #metrics) 1-        backoffDelay options attemptNo-        recordCommandRetries (options ^. #metrics) 1-        retry (attemptNo Prelude.+ 1) (Just (storeError, observedVersion))-    | isRetryableConflict storeError = do-        recordCommandConflicts (options ^. #metrics) 1-        pure (Left (RetryExhausted attemptNo storeError), attemptNo)-    | otherwise = do-        case storeError of-            DuplicateEvent{} -> recordCommandDuplicates (options ^. #metrics) 1-            _ -> pure ()-        pure (Left (StoreFailed storeError), attemptNo)--backoffDelay :: (IOE :> es) => RunCommandOptions -> Int -> Eff es ()-backoffDelay options attemptNo-    | base <= 0 = pure ()-    | otherwise = do-        nanos <- liftIO getMonotonicTimeNSec-        let exponential = min 100000 (base Prelude.* (2 Prelude.^ (attemptNo Prelude.- 1 :: Int)))-            jitter =-                Prelude.fromIntegral (nanos `Prelude.mod` Prelude.fromIntegral exponential)-                    Prelude.- (exponential `Prelude.div` 2)-        liftIO (threadDelay (max 0 (exponential Prelude.+ jitter)))-  where-    base = options ^. #retryBackoffMicros--conflictFixpoint :: Maybe (StoreError, StreamVersion) -> StreamVersion -> Maybe CommandError-conflictFixpoint (Just (previousError@StreamAlreadyExists{}, previousVersion)) currentVersion-    | currentVersion == previousVersion = Just (ConflictFixpoint currentVersion previousError)-conflictFixpoint _ _ = Nothing--evaluateCommand ::-    (BoolAlg phi (RegFile rs, ci)) =>-    EventStream phi rs s ci co ->-    Hydrated rs s ->-    ci ->-    Either CommandError [co]-evaluateCommand eventStream current command =-    case Keiki.stepEither (eventStream ^. #transducer) (state current, registers current) command of-        Left Keiki.NoOutgoingEdges{} -> Left CommandRejected-        Left Keiki.NoMatchingEdge{} -> Left CommandRejected-        Left (Keiki.AmbiguousEdges _ matches) ->-            Left-                ( CommandAmbiguous-                    [ Keiki.edgeIndex (Keiki.matchedEdge matched)-                    | matched <- matches-                    ]-                )-        Right (_, _, events) -> Right events--encodeEvents :: Codec co -> Maybe Value -> [co] -> Either CommandError [EventData]-encodeEvents codec md =-    Prelude.mapM (mapLeft EncodeFailed . encodeForAppendWithMetadata codec md)--assignEventIds :: [EventId] -> [EventData] -> [EventData]-assignEventIds [] events = events-assignEventIds _ [] = []-assignEventIds (supplied : suppliedRest) (event : eventRest) =-    (event & #eventId .~ Just supplied) : assignEventIds suppliedRest eventRest--expectedVersion :: StreamVersion -> ExpectedVersion-expectedVersion (StreamVersion 0) = NoStream-expectedVersion version = ExactVersion version--noOpResult ::-    Stream target ->-    Hydrated rs s ->-    CommandResult target-noOpResult targetStream current =-    CommandResult-        { target = targetStream-        , streamVersion = current ^. #streamVersion-        , globalPosition = Nothing-        , eventsAppended = 0-        }--appendedResult ::-    Stream target ->-    AppendResult ->-    Int ->-    CommandResult target-appendedResult targetStream appendResult count =-    CommandResult-        { target = targetStream-        , streamVersion = appendResult ^. #streamVersion-        , globalPosition = Just (appendResult ^. #globalPosition)-        , eventsAppended = count-        }--{- | Rebuild the per-event 'RecordedEvent' values for a just-appended batch.--The store assigns each event in a batch a contiguous stream version and-global position: event @i@ (1-based) gets @last - count + i@ for both-counters, where @last@ is the position the 'AppendResult' reports for the-final event and @count@ is the batch size. (The kiroku append SQL numbers-events with @WITH ORDINALITY@ and inserts @initial + idx@; see EP-27's-Surprises & Discoveries.) We therefore reconstruct each 'RecordedEvent'-exactly, rather than reading the batch back. The @createdAt@ is the same-timestamp 'prepareEventsIO'/'appendToStreamTx' used for the insert.--This is a source append (events are written to their own stream), so-@streamVersion == originalVersion@ and @originalStreamId@ is the appended-stream's id, per the 'RecordedEvent' contract.--}-reconstructRecorded :: AppendResult -> UTCTime -> [PreparedEvent] -> [RecordedEvent]-reconstructRecorded appendResult now prepared =-    Prelude.zipWith mk [0 ..] prepared-  where-    count = Prelude.length prepared-    StreamVersion lastSv = appendResult ^. #streamVersion-    GlobalPosition lastGp = appendResult ^. #globalPosition-    firstSv = lastSv Prelude.- Prelude.fromIntegral count Prelude.+ 1-    firstGp = lastGp Prelude.- Prelude.fromIntegral count Prelude.+ 1-    mk :: Int64 -> PreparedEvent -> RecordedEvent-    mk i prepared' =-        RecordedEvent-            { eventId = EventId (prepared' ^. #peEventId)-            , eventType = prepared' ^. #peEventType-            , streamVersion = StreamVersion (firstSv Prelude.+ i)-            , globalPosition = GlobalPosition (firstGp Prelude.+ i)-            , originalStreamId = appendResult ^. #streamId-            , originalVersion = StreamVersion (firstSv Prelude.+ i)-            , payload = prepared' ^. #pePayload-            , metadata = prepared' ^. #peMetadata-            , causationId = prepared' ^. #peCausationId-            , correlationId = prepared' ^. #peCorrelationId-            , createdAt = now-            }--isRetryableConflict :: StoreError -> Bool-isRetryableConflict = \case-    WrongExpectedVersion{} -> True-    StreamAlreadyExists{} -> True-    _ -> False--mapLeft :: (e -> e') -> Either e a -> Either e' a-mapLeft f = \case-    Left err -> Left (f err)-    Right value -> Right value+-- | The command side of the framework: hydrate an aggregate, transduce, append.+--+-- Running a command against an 'EventStream' follows one pipeline:+--+-- 1. /Hydrate/ — replay the stream's stored events (optionally fast-forwarding+--    from a snapshot) through the keiki transducer to recover the current+--    @(state, registers)@ and stream version.+-- 2. /Transduce/ — step the transducer with the command. A rejected transition+--    yields 'CommandRejected', while multiple matching transitions yield+--    'CommandAmbiguous'; a transition that emits no events yields a no-op+--    'CommandResult'.+-- 3. /Append/ — encode the emitted events with the stream's 'Codec' and append+--    them at the expected version. An optimistic-concurrency conflict is+--    retried up to 'retryLimit' times by rehydrating and replaying; exhausting+--    the budget yields 'RetryExhausted'.+--+-- Three runners expose this pipeline at increasing levels of integration:+--+-- * 'runCommand' — append only.+-- * 'runCommandWithSql' — run an extra @afterAppend@ action in the /same/+--   transaction as the append (e.g. update an inline read model).+-- * 'runCommandWithSqlEvents' — same, but the callback also receives the+--   emitted events paired with their 'RecordedEvent's. This is the primitive+--   the projection, process-manager, and router layers build on.+--+-- The transactional runners apply Kiroku's configured @enrichEvent@ hook before+-- event preparation, exactly like 'runCommand'. They therefore require a+-- 'KirokuStoreResource' in the effect stack; install it with @withKirokuStore@+-- and interpret 'Store' with @runStoreResource@.+--+-- Per-stream hydration honors Kiroku's stream-truncation marker. A retained+-- snapshot must cover every hidden event (snapshot version at least marker minus+-- one); otherwise hydration fails with 'HydrationGapDetected'. A marker above+-- the stream head can instead appear as an empty stream and repeated append+-- conflicts end in 'ConflictFixpoint'. Keiro never truncates streams itself.+-- Kiroku's @$all@ and category/subscription reads are unaffected by per-stream+-- truncation: the marker hides events from stream reads rather than deleting+-- them from the global log.+--+-- Every successful append is replayed immediately from its pre-command state so+-- an unreplayable batch is witnessed at the moment it poisons the stream. The+-- post-commit witness is counted and attached to the command span without+-- changing the successful result. The same replay fold feeds transparent+-- snapshot writes when the stream's 'Keiro.EventStream.SnapshotPolicy' fires;+-- post-commit snapshot failures are likewise swallowed and counted. Every runner+-- accepts a tracer for optional OpenTelemetry spans.+--+-- The additive hydration primitives are also consumed by "Keiro.ReplayAudit".+-- The audit deliberately calls the seeded and full variants separately so the+-- public command-serving fallback cannot hide a stale or unreplayable seed.+module Keiro.Command+  ( -- * Results and errors+    CommandResult (..),+    CommandError (..),+    HydrationReplayReason (..),+    commandErrorClass,++    -- * Options+    RunCommandOptions (..),+    defaultRunCommandOptions,++    -- * Running commands+    runCommand,+    runCommandWithSql,+    runCommandWithSqlEvents,++    -- * Hydration primitives (replay audit)+    Hydrated (..),+    hydrate,+    hydrateFull,+    hydrateSeeded,+  )+where++import Control.Concurrent (threadDelay)+import Control.Exception (displayException)+import Data.Aeson qualified as Aeson+import Data.ByteString.Lazy.Char8 qualified as LazyByteString+import Data.Functor (($>))+import Data.Int (Int32)+import Data.Text qualified as Text+import Effectful (Eff, IOE, (:>))+import Effectful.Concurrent (runConcurrent)+import Effectful.Concurrent.Async qualified as Async+import Effectful.Error.Static (Error, tryError)+import Effectful.Exception (trySync)+import GHC.Clock (getMonotonicTimeNSec)+import GHC.Stack (HasCallStack)+import Keiki.Core (BoolAlg, RegFile)+import Keiki.Core qualified as Keiki+import Keiro.Codec (Codec, CodecError, decodeRecorded, encodeForAppendWithMetadata)+import Keiro.EventStream (EventStream, StateCodec, Terminality (..))+import Keiro.EventStream.Validate (ValidatedEventStream, unvalidated)+import Keiro.Prelude+import Keiro.ReplayDigest (canonicalJsonBytes, replayDigest)+import Keiro.Snapshot+  ( SnapshotLookup (..),+    SnapshotMissReason (..),+    SnapshotSeed,+    encodeSnapshotStrict,+    lookupSnapshotSeed,+    writeSnapshotEncoded,+  )+import Keiro.Snapshot.Policy (shouldSnapshotSpan)+import Keiro.Stream (Stream)+import Keiro.Telemetry+  ( KeiroMetrics,+    keiro_events_appended,+    keiro_replay_divergence,+    keiro_retry_attempt,+    recordCommandConflicts,+    recordCommandDuplicates,+    recordCommandRetries,+    recordSnapshotApplyDivergence,+    recordSnapshotDecodeFailures,+    recordSnapshotEncodeFailures,+    recordSnapshotReadHits,+    recordSnapshotReadMisses,+    recordSnapshotSeedDivergence,+    recordSnapshotWriteFailures,+    withCommandSpan,+  )+import Kiroku.Store.Append (appendToStream)+import Kiroku.Store.Effect (Store)+import Kiroku.Store.Effect.Resource (KirokuStoreResource, getKirokuStore)+import Kiroku.Store.Error (StoreError (..))+import Kiroku.Store.Read (readStreamForwardStream)+import Kiroku.Store.Transaction+  ( PreparedEvent,+    appendConflictToStoreError,+    appendToStreamTx,+    enrichEventsIO,+    prepareEventsIO,+    runTransaction,+  )+import Kiroku.Store.Types+  ( AppendResult,+    EventData,+    EventId (..),+    ExpectedVersion (..),+    GlobalPosition (..),+    RecordedEvent (..),+    StreamName (..),+    StreamVersion (..),+  )+import OpenTelemetry.Attributes.Key (unkey)+import OpenTelemetry.SemanticConventions (db_system_name, error_type)+import OpenTelemetry.Trace.Core (Span, SpanStatus (..), Tracer, addAttribute, setStatus)+import Streamly.Data.Fold qualified as Fold+import Streamly.Data.Stream qualified as Streamly+import System.IO (stderr)+import System.Random.Stateful (globalStdGen, uniformRM)+import "hasql-transaction" Hasql.Transaction qualified as Tx+import Prelude qualified++-- | The outcome of a successfully handled command.+--+-- Reports the target 'Stream', the stream version after the command, the global+-- log position only when this command appended and the store assigned a real+-- one, and how many events were appended. A no-op reports @0@ events and+-- @Nothing@ for its global position because per-stream reads cannot recover a+-- true global position.+data CommandResult target = CommandResult+  { target :: !(Stream target),+    streamVersion :: !StreamVersion,+    -- | 'Just' only when this command appended; 'Nothing' for a no-op.+    globalPosition :: !(Maybe GlobalPosition),+    eventsAppended :: !Int+  }+  deriving stock (Generic, Eq, Show)++-- | Why a command did not complete.+data CommandError+  = -- | A stored event could not be decoded while rehydrating the aggregate.+    HydrationDecodeFailed !CodecError+  | -- | Replay of the stored events through the transducer stalled. The+    --       version identifies the failing stored event; for+    --       'HydrationTruncatedChain' it identifies the last stored event, after+    --       which the expected multi-event chain remained incomplete.+    HydrationReplayFailed !StreamVersion !HydrationReplayReason+  | -- | Hydration observed a non-contiguous stream version. Carries the+    --       expected version followed by the observed version. The store writes+    --       contiguous versions, so this indicates that stream truncation hid+    --       events not covered by the hydration seed. Restore visibility with+    --       @clearStreamTruncateBefore@ or provide a covering snapshot before+    --       retrying the command.+    HydrationGapDetected !StreamVersion !StreamVersion+  | -- | No transducer edge matched the command in the hydrated state.+    CommandRejected+  | -- | Two or more transducer edges matched the command in the hydrated+    --       state. This is a deterministic aggregate-definition bug rather than a+    --       business rejection; the list contains the zero-based matched edge+    --       indices in declaration order.+    CommandAmbiguous ![Int]+  | -- | An emitted event could not be encoded for append.+    EncodeFailed !CodecError+  | -- | The underlying store rejected the append.+    StoreFailed !StoreError+  | -- | Optimistic-concurrency retries were exhausted (carries the total+    --       attempts made and the last store error).+    RetryExhausted !Int !StoreError+  | -- | Retrying after a 'StreamAlreadyExists' conflict re-observed the same+    --       stream version: the store says the stream exists but reading it shows no+    --       progress. The typical cause is a soft-deleted stream, where reads return+    --       nothing but appends still collide. Carries the observed version and the+    --       conflict.+    ConflictFixpoint !StreamVersion !StoreError+  deriving stock (Generic, Eq, Show)++-- | Why replay of stored events stalled, projected from keiki's structured+-- failure types onto a monomorphic vocabulary suitable for 'CommandError'.+data HydrationReplayReason+  = -- | No edge's first output template could have produced the event.+    HydrationNoInvertingEdge+  | -- | More than one edge could have produced the event.+    HydrationAmbiguousInversion+  | -- | An event did not match the next expected event in a chain.+    HydrationQueueMismatch+  | -- | The stream ended in the middle of a multi-event chain.+    HydrationTruncatedChain+  deriving stock (Generic, Eq, Show)++-- | Knobs controlling a single command invocation.+--+-- * 'retryLimit' — how many times to rehydrate-and-replay after an+--   optimistic-concurrency conflict before giving up with 'RetryExhausted'.+-- * 'pageSize' — batch size when reading the stream during hydration.+-- * 'eventIds' — caller-supplied ids assigned to the emitted events in order;+--   the basis for deterministic, idempotent appends (see 'Keiro.Router' and+--   'Keiro.ProcessManager').+-- * 'beforeAppend' — a hook run immediately before each append attempt,+--   primarily a test seam for injecting concurrent writes.+-- * 'retryBackoffMicros' — base delay before the k-th OCC retry, capped at+--   100 ms and jittered. Set to 0 to disable backoff.+-- * 'metrics' — optional metrics handle for command and snapshot counters.+-- * 'verifyReplayOnAppend' — replay every just-appended batch from the+--   pre-command state. Divergence is a post-commit advisory: it is counted and+--   attached to the command span, but the already-successful command still+--   succeeds. Snapshot-enabled streams always run the fold because snapshots+--   consume its result.+-- * 'seedVerifySampleRate' — verify one in N snapshot seeds against a full+--   replay through the seed version. The replay runs asynchronously and never+--   blocks or fails the command. This detects hand-written fold changes that+--   leave the snapshot discriminator unchanged; @0@ disables the witness.+data RunCommandOptions = RunCommandOptions+  { retryLimit :: !Int,+    pageSize :: !Int32,+    eventIds :: ![EventId],+    beforeAppend :: !(IO ()),+    retryBackoffMicros :: !Int,+    metrics :: !(Maybe KeiroMetrics),+    verifyReplayOnAppend :: !Bool,+    seedVerifySampleRate :: !Int,+    -- | Optional OpenTelemetry tracer. When 'Just', the command runner+    --     opens an 'Internal'-kind span around each invocation, named after+    --     the resolved stream identifier and decorated with the messaging /+    --     error semantic-conventions attributes audited in+    --     'docs/research/opentelemetry-semconv-audit.md'. When 'Nothing',+    --     the runner emits no spans.+    tracer :: !(Maybe Tracer),+    -- | Optional JSON merged into every event's metadata for this command+    --     invocation. Carries ambient context such as actor type, agent id,+    --     and session id. The codec always adds a @schemaVersion@ key; the+    --     keys here are merged on top (see 'Keiro.Codec.metadataFor'). When+    --     'Nothing', events carry only the schema-version marker, exactly as+    --     before this field existed.+    metadata :: !(Maybe Value)+  }+  deriving stock (Generic)++-- | Sensible defaults: 3 retries, 256-event read pages, no caller-assigned+-- event ids, a no-op pre-append hook, 5ms retry backoff, no metrics, post-append+-- replay verification enabled, one sampled snapshot-seed verification per 1000+-- snapshot hits, no tracer, and no extra metadata.+defaultRunCommandOptions :: RunCommandOptions+defaultRunCommandOptions =+  RunCommandOptions+    { retryLimit = 3,+      pageSize = 256,+      eventIds = [],+      beforeAppend = pure (),+      retryBackoffMicros = 5000,+      metrics = Nothing,+      verifyReplayOnAppend = True,+      seedVerifySampleRate = 1000,+      tracer = Nothing,+      metadata = Nothing+    }++data Hydrated rs s = Hydrated+  { state :: !s,+    registers :: !(RegFile rs),+    streamVersion :: !StreamVersion+  }+  deriving stock (Generic)++data CommandPlan target rs s co+  = CommandNoOp !(CommandResult target)+  | CommandAppend !(Hydrated rs s) ![co] ![EventData]+  deriving stock (Generic)++hydrate ::+  forall phi rs s ci co es.+  (HasCallStack, IOE :> es, Store :> es, BoolAlg phi (RegFile rs, ci), Eq co) =>+  RunCommandOptions ->+  EventStream phi rs s ci co ->+  Stream (EventStream phi rs s ci co) ->+  Eff es (Either CommandError (Hydrated rs s))+hydrate options eventStream targetStream =+  snapshotSeed >>= \case+    Nothing -> hydrateFull options eventStream targetStream+    Just seed -> do+      replayed <-+        hydrateSeeded+          options+          eventStream+          targetStream+          (seed ^. #state)+          (seed ^. #registers)+          (seed ^. #streamVersion)+      case replayed of+        Left _ -> hydrateFull options eventStream targetStream+        Right hydrated -> do+          for_ (eventStream ^. #stateCodec) $ \codec ->+            scheduleSeedVerification options eventStream targetStream codec seed+          pure (Right hydrated)+  where+    snapshotSeed =+      case eventStream ^. #stateCodec of+        Nothing -> pure Nothing+        Just codec -> do+          lookupSnapshotSeed ((eventStream ^. #resolveStreamName) targetStream) codec >>= \case+            SnapshotHit seed -> do+              recordSnapshotReadHits (options ^. #metrics) 1+              pure (Just seed)+            SnapshotUnavailable reason -> do+              recordSnapshotReadMisses (options ^. #metrics) 1+              case reason of+                SnapshotDecodeFailed _ -> recordSnapshotDecodeFailures (options ^. #metrics) 1+                _ -> pure ()+              pure Nothing++hydrateFull ::+  forall phi rs s ci co es.+  (HasCallStack, Store :> es, BoolAlg phi (RegFile rs, ci), Eq co) =>+  RunCommandOptions ->+  EventStream phi rs s ci co ->+  Stream (EventStream phi rs s ci co) ->+  Eff es (Either CommandError (Hydrated rs s))+hydrateFull options eventStream targetStream =+  hydrateSeeded+    options+    eventStream+    targetStream+    (eventStream ^. #initialState)+    (eventStream ^. #initialRegisters)+    (StreamVersion 0)++-- | Replay a stored stream from an arbitrary snapshot or initial-state seed.+--+-- The store stream is grouped into bounded lists and each decoded prefix is+-- handed to keiki's 'Keiki.replayEvents'. Decoding stops at the first bad event in+-- a group, but the valid prefix is replayed first so an earlier replay failure+-- retains precedence over a later codec failure.+hydrateSeeded ::+  forall phi rs s ci co es.+  (HasCallStack, Store :> es, BoolAlg phi (RegFile rs, ci), Eq co) =>+  RunCommandOptions ->+  EventStream phi rs s ci co ->+  Stream (EventStream phi rs s ci co) ->+  s ->+  RegFile rs ->+  StreamVersion ->+  Eff es (Either CommandError (Hydrated rs s))+hydrateSeeded options eventStream targetStream seedState seedRegisters seedVersion = do+  hydrateSeededThrough+    Nothing+    options+    eventStream+    targetStream+    seedState+    seedRegisters+    seedVersion++hydrateSeededThrough ::+  forall phi rs s ci co es.+  (HasCallStack, Store :> es, BoolAlg phi (RegFile rs, ci), Eq co) =>+  Maybe StreamVersion ->+  RunCommandOptions ->+  EventStream phi rs s ci co ->+  Stream (EventStream phi rs s ci co) ->+  s ->+  RegFile rs ->+  StreamVersion ->+  Eff es (Either CommandError (Hydrated rs s))+hydrateSeededThrough replayThrough options eventStream targetStream seedState seedRegisters seedVersion = do+  replayed <-+    Streamly.fold+      (Fold.foldlM' replayPage (pure (Right initialReplay)))+      recordedPages+  pure (finishReplay replayed)+  where+    readPageSize = Prelude.max 1 (options ^. #pageSize)+    groupSize = Prelude.fromIntegral readPageSize+    recordedPages =+      Streamly.foldMany+        (Fold.take groupSize Fold.toList)+        boundedRecorded+    boundedRecorded =+      case replayThrough of+        Nothing -> readStreamForwardStream resolvedName seedVersion readPageSize+        Just endVersion ->+          Streamly.takeWhile+            (\recorded -> recorded ^. #streamVersion <= endVersion)+            (readStreamForwardStream resolvedName seedVersion readPageSize)+    resolvedName = (eventStream ^. #resolveStreamName) targetStream+    initialReplay = (Keiki.Settled seedState, seedRegisters, Nothing)++    replayPage ::+      Either CommandError (Keiki.InFlight s co, RegFile rs, Maybe RecordedEvent) ->+      [RecordedEvent] ->+      Eff es (Either CommandError (Keiki.InFlight s co, RegFile rs, Maybe RecordedEvent))+    replayPage (Left err) _ = pure (Left err)+    replayPage (Right (wrapper, registers, previousRecorded)) page =+      pure $ case Keiki.replayEvents (eventStream ^. #transducer) (wrapper, registers) decodedEvents of+        Left replayFailure ->+          Left (hydrationReplayError previousRecorded decodedRecorded replayFailure)+        Right (nextWrapper, nextRegisters) ->+          case pendingInputFailure of+            Just err -> Left err+            Nothing ->+              Right+                ( nextWrapper,+                  nextRegisters,+                  latestRecorded decodedRecorded previousRecorded+                )+      where+        (decodedRecorded, decodedEvents, pendingInputFailure) = decodePrefix previousRecorded page++    decodePrefix :: Maybe RecordedEvent -> [RecordedEvent] -> ([RecordedEvent], [co], Maybe CommandError)+    decodePrefix previousRecorded = go [] [] startingVersion+      where+        startingVersion = maybe seedVersion (^. #streamVersion) previousRecorded++        go recordedAcc eventAcc lastSeen = \case+          [] -> (Prelude.reverse recordedAcc, Prelude.reverse eventAcc, Nothing)+          recorded : rest ->+            let observed = recorded ^. #streamVersion+                expected = nextStreamVersion lastSeen+             in if observed /= expected+                  then+                    ( Prelude.reverse recordedAcc,+                      Prelude.reverse eventAcc,+                      Just (HydrationGapDetected expected observed)+                    )+                  else case decodeRecorded (eventStream ^. #eventCodec) recorded of+                    Left err ->+                      ( Prelude.reverse recordedAcc,+                        Prelude.reverse eventAcc,+                        Just (HydrationDecodeFailed err)+                      )+                    Right event ->+                      go (recorded : recordedAcc) (event : eventAcc) observed rest++        nextStreamVersion (StreamVersion version) = StreamVersion (version Prelude.+ 1)++    hydrationReplayError ::+      Maybe RecordedEvent ->+      [RecordedEvent] ->+      Keiki.ReplayFailure s co ->+      CommandError+    hydrationReplayError previousRecorded decodedRecorded replayFailure =+      HydrationReplayFailed failureVersion (toHydrationReason (Keiki.replayFailureReason replayFailure))+      where+        failureVersion =+          maybe seedVersion (^. #streamVersion) failureRecorded+        failureRecorded =+          case Keiki.replayFailureReason replayFailure of+            Keiki.ReplayLogTruncated {} -> latestRecorded decodedRecorded previousRecorded+            Keiki.ReplayEventFailed {} ->+              case recordedAt (Keiki.replayFailedIndex replayFailure) decodedRecorded of+                Just recorded -> Just recorded+                Nothing -> latestRecorded decodedRecorded previousRecorded++    finishReplay = \case+      Left err -> Left err+      Right (wrapper, finalRegisters, lastRecorded) ->+        case wrapper of+          Keiki.Settled finalState ->+            Right+              Hydrated+                { state = finalState,+                  registers = finalRegisters,+                  streamVersion = maybe seedVersion (^. #streamVersion) lastRecorded+                }+          Keiki.InFlight {} ->+            Left+              ( HydrationReplayFailed+                  (maybe seedVersion (^. #streamVersion) lastRecorded)+                  HydrationTruncatedChain+              )++    toHydrationReason = \case+      Keiki.ReplayEventFailed stepFailure -> case stepFailure of+        Keiki.ReplayNoInvertingEdge {} -> HydrationNoInvertingEdge+        Keiki.ReplayAmbiguousInversions {} -> HydrationAmbiguousInversion+        Keiki.ReplayQueueMismatch {} -> HydrationQueueMismatch+      Keiki.ReplayLogTruncated {} -> HydrationTruncatedChain++    latestRecorded recorded fallback =+      case lastMaybe recorded of+        Just latest -> Just latest+        Nothing -> fallback++    lastMaybe = \case+      [] -> Nothing+      first : rest -> Just (Prelude.foldl (\_ current -> current) first rest)++    recordedAt eventIndex recorded =+      case Prelude.drop eventIndex recorded of+        found : _ -> Just found+        [] -> Nothing++scheduleSeedVerification ::+  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) ->+  StateCodec (s, RegFile rs) ->+  SnapshotSeed rs s ->+  Eff es ()+scheduleSeedVerification options eventStream targetStream codec seed = do+  void $ trySync $ do+    sampled <-+      case options ^. #seedVerifySampleRate of+        rate | rate <= 0 -> pure False+        1 -> pure True+        rate -> liftIO ((== (1 :: Int)) <$> uniformRM (1, rate) globalStdGen)+    when sampled+      $ void+      $ runConcurrent+      $ Async.async+      $ verifySnapshotSeed options eventStream targetStream codec seed++verifySnapshotSeed ::+  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) ->+  StateCodec (s, RegFile rs) ->+  SnapshotSeed rs s ->+  Eff es ()+verifySnapshotSeed options eventStream targetStream codec seed = do+  let seedVersion = seed ^. #streamVersion+      streamName = (eventStream ^. #resolveStreamName) targetStream+  full <-+    hydrateSeededThrough+      (Just seedVersion)+      options+      eventStream+      targetStream+      (eventStream ^. #initialState)+      (eventStream ^. #initialRegisters)+      (StreamVersion 0)+  seededEncoded <-+    liftIO+      $ encodeSnapshotStrict+        codec+        (seed ^. #state, seed ^. #registers)+  case (seededEncoded, full) of+    (Left seedEncodeError, _) ->+      reportSeedDivergence+        options+        streamName+        seedVersion+        ("encode-failed:" <> Text.pack (displayException seedEncodeError))+        (case full of Left replayError -> "replay-failed:" <> Text.pack (show replayError); Right _ -> "not-compared:seed-encode-failed")+    (Right seededValue, Left replayError) ->+      reportSeedDivergence+        options+        streamName+        seedVersion+        (replayDigest seededValue)+        ("replay-failed:" <> Text.pack (show replayError))+    (Right seededValue, Right fullHydrated)+      | fullHydrated ^. #streamVersion /= seedVersion ->+          reportSeedDivergence+            options+            streamName+            seedVersion+            (replayDigest seededValue)+            ("version-mismatch:" <> Text.pack (show (fullHydrated ^. #streamVersion)))+      | otherwise -> do+          fullEncoded <-+            liftIO+              $ encodeSnapshotStrict+                codec+                (fullHydrated ^. #state, fullHydrated ^. #registers)+          case fullEncoded of+            Left fullEncodeError ->+              reportSeedDivergence+                options+                streamName+                seedVersion+                (replayDigest seededValue)+                ("encode-failed:" <> Text.pack (displayException fullEncodeError))+            Right fullValue ->+              unless+                (canonicalJsonBytes seededValue == canonicalJsonBytes fullValue)+                ( reportSeedDivergence+                    options+                    streamName+                    seedVersion+                    (replayDigest seededValue)+                    (replayDigest fullValue)+                )++reportSeedDivergence ::+  (IOE :> es) =>+  RunCommandOptions ->+  StreamName ->+  StreamVersion ->+  Text ->+  Text ->+  Eff es ()+reportSeedDivergence options (StreamName streamName) (StreamVersion seedVersion) seededDigest fullDigest = do+  recordSnapshotSeedDivergence (options ^. #metrics) 1+  liftIO+    $ LazyByteString.hPutStrLn stderr+    $ Aeson.encode+    $ Aeson.object+      [ "event" Aeson..= ("keiro.snapshot.seed.divergence" :: Text),+        "level" Aeson..= ("error" :: Text),+        "stream" Aeson..= streamName,+        "seedVersion" Aeson..= seedVersion,+        "seededDigest" Aeson..= seededDigest,+        "fullDigest" Aeson..= fullDigest+      ]++-- | Hydrate the target stream, transduce the command, and append any emitted+-- events. Retries optimistic-concurrency conflicts up to 'retryLimit'. This+-- is the plain runner with no in-transaction side effects.+runCommand ::+  forall phi rs s ci co es.+  (HasCallStack, IOE :> es, Store :> es, Error StoreError :> es, BoolAlg phi (RegFile rs, ci), Eq co) =>+  RunCommandOptions ->+  ValidatedEventStream phi rs s ci co ->+  Stream (EventStream phi rs s ci co) ->+  ci ->+  Eff es (Either CommandError (CommandResult (EventStream phi rs s ci co)))+runCommand options validatedEventStream targetStream command =+  withCommandSpan (options ^. #tracer) (resolvedStreamName eventStream targetStream) Nothing $ \mSpan -> do+    (result, attemptNo) <- attempt mSpan 1 Nothing+    recordCommandOutcome mSpan (^. #eventsAppended) attemptNo result+    pure result+  where+    eventStream = unvalidated validatedEventStream++    attempt mSpan attemptNo lastConflict = do+      hydrated <- hydrate options eventStream targetStream+      either (\err -> pure (Left err, attemptNo)) (runPlan mSpan attemptNo lastConflict) hydrated++    runPlan mSpan attemptNo lastConflict current =+      case conflictFixpoint lastConflict (current ^. #streamVersion) of+        Just err -> pure (Left err, attemptNo)+        Nothing ->+          case prepareCommandPlan options eventStream targetStream current command of+            Left err -> pure (Left err, attemptNo)+            Right (CommandNoOp result) -> pure (Right result, attemptNo)+            Right (CommandAppend current' events encoded) ->+              appendOnce mSpan attemptNo current' events encoded++    appendOnce mSpan attemptNo current events encoded = do+      liftIO (options ^. #beforeAppend)+      appended <-+        tryError @StoreError+          $ appendToStream+            ((eventStream ^. #resolveStreamName) targetStream)+            (expectedVersion (current ^. #streamVersion))+            encoded+      case appended of+        Right appendResult -> do+          verifyAndSnapshot options mSpan eventStream current events appendResult+          pure (Right (appendedResult targetStream appendResult (Prelude.length encoded)), attemptNo)+        Left (_, storeError) ->+          retryOrFail options (attempt mSpan) attemptNo (current ^. #streamVersion) storeError++-- | Like 'runCommand', but run @afterAppend@ inside the /same/ transaction+-- as the append, so a read-model write commits atomically with the events.+-- The callback's result is returned as @Just@ on append (and 'Nothing' for a+-- no-op command that appended nothing).+--+-- Requires 'KirokuStoreResource' so the transactional append applies the+-- configured @enrichEvent@ hook. See 'runCommandWithSqlEvents' for the callback's+-- locking and latency implications.+runCommandWithSql ::+  forall phi rs s ci co a es.+  (HasCallStack, IOE :> es, Store :> es, Error StoreError :> es, KirokuStoreResource :> es, BoolAlg phi (RegFile rs, ci), Eq co) =>+  RunCommandOptions ->+  ValidatedEventStream phi rs s ci co ->+  Stream (EventStream phi rs s ci co) ->+  ci ->+  (AppendResult -> Tx.Transaction a) ->+  Eff es (Either CommandError (CommandResult (EventStream phi rs s ci co), Maybe a))+runCommandWithSql options eventStream targetStream command afterAppend =+  runCommandWithSqlEvents options eventStream targetStream command (\_ appendResult -> afterAppend appendResult)++-- | The most general runner: like 'runCommandWithSql', but the+-- in-transaction callback also receives every emitted event paired with the+-- 'RecordedEvent' the store persisted for it, in append order. Inline+-- projections, process managers, and routers are all built on this.+--+-- The runner requires 'KirokuStoreResource' and applies the configured+-- @enrichEvent@ hook before preparing the append. The callback therefore sees+-- the enriched metadata that was persisted.+--+-- The append updates Kiroku's global @$all@ stream and holds its PostgreSQL row+-- lock until this transaction commits. Every SQL operation in the callback+-- therefore extends the store-wide append serialization window. Keep the+-- callback small: precompute outside the transaction where possible, batch+-- writes, and minimize database round trips.+runCommandWithSqlEvents ::+  forall phi rs s ci co a es.+  (HasCallStack, IOE :> es, Store :> es, Error StoreError :> es, KirokuStoreResource :> es, BoolAlg phi (RegFile rs, ci), Eq co) =>+  RunCommandOptions ->+  ValidatedEventStream phi rs s ci co ->+  Stream (EventStream phi rs s ci co) ->+  ci ->+  ([(co, RecordedEvent)] -> AppendResult -> Tx.Transaction a) ->+  Eff es (Either CommandError (CommandResult (EventStream phi rs s ci co), Maybe a))+runCommandWithSqlEvents options validatedEventStream targetStream command afterAppend =+  withCommandSpan (options ^. #tracer) (resolvedStreamName eventStream targetStream) Nothing $ \mSpan -> do+    (result, attemptNo) <- attempt mSpan 1 Nothing+    recordCommandOutcome mSpan (\(r, _) -> r ^. #eventsAppended) attemptNo result+    pure result+  where+    eventStream = unvalidated validatedEventStream++    attempt mSpan attemptNo lastConflict = do+      hydrated <- hydrate options eventStream targetStream+      either (\err -> pure (Left err, attemptNo)) (runPlan mSpan attemptNo lastConflict) hydrated++    runPlan mSpan attemptNo lastConflict current =+      case conflictFixpoint lastConflict (current ^. #streamVersion) of+        Just err -> pure (Left err, attemptNo)+        Nothing ->+          case prepareCommandPlan options eventStream targetStream current command of+            Left err -> pure (Left err, attemptNo)+            Right (CommandNoOp result) -> pure (Right (result, Nothing), attemptNo)+            Right (CommandAppend current' events encoded) ->+              appendWithSqlOnce mSpan attemptNo current' events encoded++    appendWithSqlOnce mSpan attemptNo current events encoded = do+      liftIO (options ^. #beforeAppend)+      store <- getKirokuStore+      enriched <- liftIO (enrichEventsIO store encoded)+      prepared <- prepareEventsIO enriched+      now <- liftIO getCurrentTime+      let streamName = (eventStream ^. #resolveStreamName) targetStream+          expected = expectedVersion (current ^. #streamVersion)+          body = do+            appended <- appendToStreamTx streamName expected prepared now+            case appended of+              Left conflict ->+                Tx.condemn $> Left (appendConflictToStoreError conflict)+              Right appendResult -> do+                let recordeds = reconstructRecorded appendResult now prepared+                userValue <- afterAppend (Prelude.zip events recordeds) appendResult+                pure (Right (appendResult, userValue))+      outcome <- tryError @StoreError (runTransaction body)+      case outcome of+        Right (Right (appendResult, userValue)) -> do+          verifyAndSnapshot options mSpan eventStream current events appendResult+          pure (Right (appendedResult targetStream appendResult (Prelude.length encoded), Just userValue), attemptNo)+        Right (Left storeError) ->+          retryOrFail options (attempt mSpan) attemptNo (current ^. #streamVersion) storeError+        Left (_, storeError) ->+          retryOrFail options (attempt mSpan) attemptNo (current ^. #streamVersion) storeError++prepareCommandPlan ::+  (BoolAlg phi (RegFile rs, ci)) =>+  RunCommandOptions ->+  EventStream phi rs s ci co ->+  Stream (EventStream phi rs s ci co) ->+  Hydrated rs s ->+  ci ->+  Either CommandError (CommandPlan (EventStream phi rs s ci co) rs s co)+prepareCommandPlan options eventStream targetStream current command =+  case evaluateCommand eventStream current command of+    Left err -> Left err+    Right events -> toPlan events+  where+    toPlan [] =+      Right (CommandNoOp (noOpResult targetStream current))+    toPlan events =+      CommandAppend current events+        . assignEventIds (options ^. #eventIds)+        <$> encodeEvents (eventStream ^. #eventCodec) (options ^. #metadata) events++-- | Render the stream that the command targets as plain 'Text', for use+-- as a span name.+resolvedStreamName ::+  EventStream phi rs s ci co ->+  Stream (EventStream phi rs s ci co) ->+  Text+resolvedStreamName eventStream targetStream =+  case (eventStream ^. #resolveStreamName) targetStream of+    StreamName n -> n++-- | Attach the command-span outcome attributes after the runner returns.+--+-- On success: 'db.system.name' and 'keiro.events.appended'.+-- On failure: 'error.type' (low-cardinality classifier) and span status+-- 'Error' (carrying the rendered 'CommandError' as the description).+--+-- Pure no-op when no span is active ('Nothing' tracer, etc).+recordCommandOutcome ::+  (IOE :> es) =>+  Maybe Span ->+  (a -> Int) ->+  Int ->+  Either CommandError a ->+  Eff es ()+recordCommandOutcome Nothing _ _ _ = pure ()+recordCommandOutcome (Just sp) eventsOf attemptNo result = do+  addAttribute sp (unkey db_system_name) ("postgresql" :: Text)+  addAttribute sp (unkey keiro_retry_attempt) (Prelude.fromIntegral attemptNo :: Int64)+  case result of+    Right v ->+      addAttribute sp (unkey keiro_events_appended) (Prelude.fromIntegral (eventsOf v) :: Int64)+    Left err -> do+      addAttribute sp (unkey error_type) (commandErrorClass err)+      setStatus sp (Error (Text.take 256 (Text.pack (show err))))++-- | Low-cardinality classifier for a 'CommandError'. Used as the+-- @error.type@ attribute value on the command span.+commandErrorClass :: CommandError -> Text+commandErrorClass = \case+  HydrationDecodeFailed {} -> "hydration_decode_failed"+  HydrationReplayFailed _ HydrationNoInvertingEdge -> "hydration_replay_no_inverting_edge"+  HydrationReplayFailed _ HydrationAmbiguousInversion -> "hydration_replay_ambiguous_inversion"+  HydrationReplayFailed _ HydrationQueueMismatch -> "hydration_replay_queue_mismatch"+  HydrationReplayFailed _ HydrationTruncatedChain -> "hydration_replay_truncated_chain"+  HydrationGapDetected {} -> "hydration_gap_detected"+  CommandRejected -> "command_rejected"+  CommandAmbiguous {} -> "command_ambiguous"+  EncodeFailed {} -> "encode_failed"+  StoreFailed {} -> "store_failed"+  RetryExhausted {} -> "retry_exhausted"+  ConflictFixpoint {} -> "conflict_fixpoint"++verifyAndSnapshot ::+  forall phi rs s ci co es.+  (BoolAlg phi (RegFile rs, ci), IOE :> es, Store :> es, Error StoreError :> es, Eq co) =>+  RunCommandOptions ->+  Maybe Span ->+  EventStream phi rs s ci co ->+  Hydrated rs s ->+  [co] ->+  AppendResult ->+  Eff es ()+verifyAndSnapshot options mSpan eventStream current events appendResult+  | Prelude.not (options ^. #verifyReplayOnAppend),+    Nothing <- eventStream ^. #stateCodec =+      pure ()+  | otherwise =+      case Keiki.applyEventsEither (eventStream ^. #transducer) (state current, registers current) events of+        Left failure -> do+          recordSnapshotApplyDivergence (options ^. #metrics) 1+          for_ mSpan $ \sp ->+            addAttribute+              sp+              (unkey keiro_replay_divergence)+              (Text.take 256 (renderReplayFailure failure))+        Right finalState ->+          case eventStream ^. #stateCodec of+            Nothing -> pure ()+            Just codec -> do+              let finalVersion = appendResult ^. #streamVersion+                  terminality =+                    if Keiki.isFinal (eventStream ^. #transducer) (Prelude.fst finalState)+                      then Terminal+                      else NotTerminal+              when (shouldSnapshotSpan (eventStream ^. #snapshotPolicy) terminality finalState (current ^. #streamVersion) finalVersion)+                $ do+                  encoded <- liftIO (encodeSnapshotStrict codec finalState)+                  case encoded of+                    Left _ -> recordSnapshotEncodeFailures (options ^. #metrics) 1+                    Right value -> do+                      outcome <- tryError @StoreError (writeSnapshotEncoded (appendResult ^. #streamId) finalVersion codec value)+                      case outcome of+                        Right () -> pure ()+                        Left _ -> recordSnapshotWriteFailures (options ^. #metrics) 1++renderReplayFailure :: Keiki.ReplayFailure s co -> Text+renderReplayFailure failure =+  "event_index="+    <> Text.pack (show (Keiki.replayFailedIndex failure))+    <> ";reason="+    <> case Keiki.replayFailureReason failure of+      Keiki.ReplayEventFailed stepFailure -> case stepFailure of+        Keiki.ReplayNoInvertingEdge {} -> "no_inverting_edge"+        Keiki.ReplayAmbiguousInversions {} -> "ambiguous_inversions"+        Keiki.ReplayQueueMismatch {} -> "queue_mismatch"+      Keiki.ReplayLogTruncated {} -> "log_truncated"++retryOrFail ::+  (IOE :> es) =>+  RunCommandOptions ->+  (Int -> Maybe (StoreError, StreamVersion) -> Eff es (Either CommandError a, Int)) ->+  Int ->+  StreamVersion ->+  StoreError ->+  Eff es (Either CommandError a, Int)+retryOrFail options retry attemptNo observedVersion storeError+  | isRetryableConflict storeError,+    attemptNo <= options ^. #retryLimit = do+      recordCommandConflicts (options ^. #metrics) 1+      backoffDelay options attemptNo+      recordCommandRetries (options ^. #metrics) 1+      retry (attemptNo Prelude.+ 1) (Just (storeError, observedVersion))+  | isRetryableConflict storeError = do+      recordCommandConflicts (options ^. #metrics) 1+      pure (Left (RetryExhausted attemptNo storeError), attemptNo)+  | otherwise = do+      case storeError of+        DuplicateEvent {} -> recordCommandDuplicates (options ^. #metrics) 1+        _ -> pure ()+      pure (Left (StoreFailed storeError), attemptNo)++backoffDelay :: (IOE :> es) => RunCommandOptions -> Int -> Eff es ()+backoffDelay options attemptNo+  | base <= 0 = pure ()+  | otherwise = do+      nanos <- liftIO getMonotonicTimeNSec+      let exponential = min 100000 (base Prelude.* (2 Prelude.^ (attemptNo Prelude.- 1 :: Int)))+          jitter =+            Prelude.fromIntegral (nanos `Prelude.mod` Prelude.fromIntegral exponential)+              Prelude.- (exponential `Prelude.div` 2)+      liftIO (threadDelay (max 0 (exponential Prelude.+ jitter)))+  where+    base = options ^. #retryBackoffMicros++conflictFixpoint :: Maybe (StoreError, StreamVersion) -> StreamVersion -> Maybe CommandError+conflictFixpoint (Just (previousError@StreamAlreadyExists {}, previousVersion)) currentVersion+  | currentVersion == previousVersion = Just (ConflictFixpoint currentVersion previousError)+conflictFixpoint _ _ = Nothing++evaluateCommand ::+  (BoolAlg phi (RegFile rs, ci)) =>+  EventStream phi rs s ci co ->+  Hydrated rs s ->+  ci ->+  Either CommandError [co]+evaluateCommand eventStream current command =+  case Keiki.stepEither (eventStream ^. #transducer) (state current, registers current) command of+    Left Keiki.NoOutgoingEdges {} -> Left CommandRejected+    Left Keiki.NoMatchingEdge {} -> Left CommandRejected+    Left (Keiki.AmbiguousEdges _ matches) ->+      Left+        ( CommandAmbiguous+            [ Keiki.edgeIndex (Keiki.matchedEdge matched)+            | matched <- matches+            ]+        )+    Right (_, _, events) -> Right events++encodeEvents :: Codec co -> Maybe Value -> [co] -> Either CommandError [EventData]+encodeEvents codec md =+  Prelude.mapM (mapLeft EncodeFailed . encodeForAppendWithMetadata codec md)++assignEventIds :: [EventId] -> [EventData] -> [EventData]+assignEventIds [] events = events+assignEventIds _ [] = []+assignEventIds (supplied : suppliedRest) (event : eventRest) =+  (event & #eventId .~ Just supplied) : assignEventIds suppliedRest eventRest++expectedVersion :: StreamVersion -> ExpectedVersion+expectedVersion (StreamVersion 0) = NoStream+expectedVersion version = ExactVersion version++noOpResult ::+  Stream target ->+  Hydrated rs s ->+  CommandResult target+noOpResult targetStream current =+  CommandResult+    { target = targetStream,+      streamVersion = current ^. #streamVersion,+      globalPosition = Nothing,+      eventsAppended = 0+    }++appendedResult ::+  Stream target ->+  AppendResult ->+  Int ->+  CommandResult target+appendedResult targetStream appendResult count =+  CommandResult+    { target = targetStream,+      streamVersion = appendResult ^. #streamVersion,+      globalPosition = Just (appendResult ^. #globalPosition),+      eventsAppended = count+    }++-- | Rebuild the per-event 'RecordedEvent' values for a just-appended batch.+--+-- The store assigns each event in a batch a contiguous stream version and+-- global position: event @i@ (1-based) gets @last - count + i@ for both+-- counters, where @last@ is the position the 'AppendResult' reports for the+-- final event and @count@ is the batch size. (The kiroku append SQL numbers+-- events with @WITH ORDINALITY@ and inserts @initial + idx@; see EP-27's+-- Surprises & Discoveries.) We therefore reconstruct each 'RecordedEvent'+-- exactly, rather than reading the batch back. The @createdAt@ is the same+-- timestamp 'prepareEventsIO'/'appendToStreamTx' used for the insert.+--+-- This is a source append (events are written to their own stream), so+-- @streamVersion == originalVersion@ and @originalStreamId@ is the appended+-- stream's id, per the 'RecordedEvent' contract.+reconstructRecorded :: AppendResult -> UTCTime -> [PreparedEvent] -> [RecordedEvent]+reconstructRecorded appendResult now prepared =+  Prelude.zipWith mk [0 ..] prepared+  where+    count = Prelude.length prepared+    StreamVersion lastSv = appendResult ^. #streamVersion+    GlobalPosition lastGp = appendResult ^. #globalPosition+    firstSv = lastSv Prelude.- Prelude.fromIntegral count Prelude.+ 1+    firstGp = lastGp Prelude.- Prelude.fromIntegral count Prelude.+ 1+    mk :: Int64 -> PreparedEvent -> RecordedEvent+    mk i prepared' =+      RecordedEvent+        { eventId = EventId (prepared' ^. #peEventId),+          eventType = prepared' ^. #peEventType,+          streamVersion = StreamVersion (firstSv Prelude.+ i),+          globalPosition = GlobalPosition (firstGp Prelude.+ i),+          originalStreamId = appendResult ^. #streamId,+          originalVersion = StreamVersion (firstSv Prelude.+ i),+          payload = prepared' ^. #pePayload,+          metadata = prepared' ^. #peMetadata,+          causationId = prepared' ^. #peCausationId,+          correlationId = prepared' ^. #peCorrelationId,+          createdAt = now+        }++isRetryableConflict :: StoreError -> Bool+isRetryableConflict = \case+  WrongExpectedVersion {} -> True+  StreamAlreadyExists {} -> True+  _ -> False++mapLeft :: (e -> e') -> Either e a -> Either e' a+mapLeft f = \case+  Left err -> Left (f err)+  Right value -> Right value
src/Keiro/Connection.hs view
@@ -1,41 +1,40 @@-{- | Schema-resolution helpers for application read-model and projection tables.--Keiro's own framework tables live in the dedicated @keiro@ schema and its-runtime queries are fully qualified there. This module is about the /third/-layer: where an application's read-model /data/ tables live, and how the-application declares and reaches that location.--A PostgreSQL /schema/ is a namespace of tables inside one database. Because-Keiro opens its database pool through kiroku's connection settings — whose-@search_path@ starts with the event store's private @kiroku@ schema — an-unqualified @CREATE TABLE my_read_model (...)@ would land the table inside the-@kiroku@ event-store schema. To place it elsewhere, the application must-qualify at least its @CREATE TABLE@ as @schema.table@ (an unqualified create-always lands in the first @search_path@ entry). Qualifying the read/write SQL-too makes everything correct regardless of @search_path@ — the robust default.--This module gives applications exactly one convention:--* 'qualifyTable' builds a double-quoted, schema-qualified table reference to-  interpolate into projection SQL.-* 'withProjectionSchema' / 'keiroConnectionSettings' wire the store connection-  so a chosen projection schema also /resolves/ on the pool (via kiroku's-  @extraSearchPath@), for applications that also want unqualified SQL to work.-* 'ensureProjectionSchema' is an opt-in @CREATE SCHEMA IF NOT EXISTS@ helper for-  development, tests, and worked examples; Keiro never calls it automatically.--The kiroku store connection's @schema@ field stays @kiroku@ and is never-repointed: it also drives the @<schema>.events@ @LISTEN@/@NOTIFY@ channel, so-changing it would break subscription wake-ups. The projection schema is reached-only by qualification and\/or @extraSearchPath@.--}-module Keiro.Connection (-    qualifyTable,+-- | Schema-resolution helpers for application read-model and projection tables.+--+-- Keiro's own framework tables live in the dedicated @keiro@ schema and its+-- runtime queries are fully qualified there. This module is about the /third/+-- layer: where an application's read-model /data/ tables live, and how the+-- application declares and reaches that location.+--+-- A PostgreSQL /schema/ is a namespace of tables inside one database. Because+-- Keiro opens its database pool through kiroku's connection settings — whose+-- @search_path@ starts with the event store's private @kiroku@ schema — an+-- unqualified @CREATE TABLE my_read_model (...)@ would land the table inside the+-- @kiroku@ event-store schema. To place it elsewhere, the application must+-- qualify at least its @CREATE TABLE@ as @schema.table@ (an unqualified create+-- always lands in the first @search_path@ entry). Qualifying the read/write SQL+-- too makes everything correct regardless of @search_path@ — the robust default.+--+-- This module gives applications exactly one convention:+--+-- * 'qualifyTable' builds a double-quoted, schema-qualified table reference to+--   interpolate into projection SQL.+-- * 'withProjectionSchema' / 'keiroConnectionSettings' wire the store connection+--   so a chosen projection schema also /resolves/ on the pool (via kiroku's+--   @extraSearchPath@), for applications that also want unqualified SQL to work.+-- * 'ensureProjectionSchema' is an opt-in @CREATE SCHEMA IF NOT EXISTS@ helper for+--   development, tests, and worked examples; Keiro never calls it automatically.+--+-- The kiroku store connection's @schema@ field stays @kiroku@ and is never+-- repointed: it also drives the @<schema>.events@ @LISTEN@/@NOTIFY@ channel, so+-- changing it would break subscription wake-ups. The projection schema is reached+-- only by qualification and\/or @extraSearchPath@.+module Keiro.Connection+  ( qualifyTable,     quoteIdentifier,     withProjectionSchema,     keiroConnectionSettings,     ensureProjectionSchema,-)+  ) where  import Data.Text qualified as T@@ -47,54 +46,49 @@ import Kiroku.Store.Transaction (runTransaction) import "hasql-transaction" Hasql.Transaction qualified as Tx -{- | Build a double-quoted, schema-qualified table reference @"schema"."table"@,-doubling any embedded double quotes (the same identifier quoting kiroku uses).-Interpolate the result directly into projection SQL, e.g.--@-"SELECT ... FROM " <> qualifyTable "app" "orders" <> " WHERE ..."-@--}+-- | Build a double-quoted, schema-qualified table reference @"schema"."table"@,+-- doubling any embedded double quotes (the same identifier quoting kiroku uses).+-- Interpolate the result directly into projection SQL, e.g.+--+-- @+-- "SELECT ... FROM " <> qualifyTable "app" "orders" <> " WHERE ..."+-- @ qualifyTable :: Text -> Text -> Text qualifyTable schema table = quoteIdentifier schema <> "." <> quoteIdentifier table -{- | Double-quote a single SQL identifier, doubling any embedded double quotes-(the same identifier quoting kiroku uses). Useful for building qualified names-or a @CREATE SCHEMA "<name>"@ statement.--}+-- | Double-quote a single SQL identifier, doubling any embedded double quotes+-- (the same identifier quoting kiroku uses). Useful for building qualified names+-- or a @CREATE SCHEMA "<name>"@ statement. quoteIdentifier :: Text -> Text quoteIdentifier ident = "\"" <> T.replace "\"" "\"\"" ident <> "\"" -{- | Append @projectionSchema@ to a settings value's @extraSearchPath@ so a-pooled connection can /resolve/ (read\/write) application tables in that schema.-Idempotent: the schema is appended only if not already present. The store's-@schema@ field is left untouched (stays @kiroku@).--}+-- | Append @projectionSchema@ to a settings value's @extraSearchPath@ so a+-- pooled connection can /resolve/ (read\/write) application tables in that schema.+-- Idempotent: the schema is appended only if not already present. The store's+-- @schema@ field is left untouched (stays @kiroku@). withProjectionSchema :: Text -> ConnectionSettings -> ConnectionSettings withProjectionSchema projectionSchema settings =-    settings & #extraSearchPath %~ appendUnique projectionSchema+  settings & #extraSearchPath %~ appendUnique projectionSchema   where     appendUnique s xs-        | s `elem` xs = xs-        | otherwise = xs <> [s]+      | s `elem` xs = xs+      | otherwise = xs <> [s] -{- | kiroku's default connection settings (@schema = "kiroku"@) with-@projectionSchema@ added to @extraSearchPath@, so unqualified application-data-manipulation SQL resolves on the store pool while the store @schema@ stays-@kiroku@ (honoring the NOTIFY-channel constraint). This does /not/ bake Keiro's-own @keiro@ schema into @extraSearchPath@: Keiro's runtime queries are already-fully qualified and must not depend on @search_path@.--}+-- | kiroku's default connection settings (@schema = "kiroku"@) with+-- @projectionSchema@ added to @extraSearchPath@, so unqualified application+-- data-manipulation SQL resolves on the store pool while the store @schema@ stays+-- @kiroku@ (honoring the NOTIFY-channel constraint). This does /not/ bake Keiro's+-- own @keiro@ schema into @extraSearchPath@: Keiro's runtime queries are already+-- fully qualified and must not depend on @search_path@. keiroConnectionSettings :: Text -> Text -> ConnectionSettings keiroConnectionSettings connString projectionSchema =-    withProjectionSchema projectionSchema (defaultConnectionSettings connString)+  withProjectionSchema projectionSchema (defaultConnectionSettings connString) -{- | Run @CREATE SCHEMA IF NOT EXISTS "<schema>"@ in a transaction. This is-opt-in: Keiro never calls it automatically. Use it in development, tests, and-worked examples where the application (not a production migration tool) owns-schema creation.--}+-- | Run @CREATE SCHEMA IF NOT EXISTS "<schema>"@ in a transaction. This is+-- opt-in: Keiro never calls it automatically. Use it in development, tests, and+-- worked examples where the application (not a production migration tool) owns+-- schema creation. ensureProjectionSchema :: (Store :> es) => Text -> Eff es () ensureProjectionSchema projectionSchema =-    runTransaction $-        Tx.sql (TE.encodeUtf8 ("CREATE SCHEMA IF NOT EXISTS " <> quoteIdentifier projectionSchema))+  runTransaction $+    Tx.sql (TE.encodeUtf8 ("CREATE SCHEMA IF NOT EXISTS " <> quoteIdentifier projectionSchema))
src/Keiro/DeadLetter.hs view
@@ -1,27 +1,26 @@-{- | Durable records for process-manager and router dispatches rejected by a-target state machine.--Use 'recordDispatchDeadLetter' from a worker before acknowledging its source-event, and 'listDispatchDeadLetters' to inspect the durable witnesses for one-dispatcher. Inserts are idempotent under source-event redelivery.--}-module Keiro.DeadLetter (-    DispatcherKind (..),+-- | Durable records for process-manager and router dispatches rejected by a+-- target state machine.+--+-- Use 'recordDispatchDeadLetter' from a worker before acknowledging its source+-- event, and 'listDispatchDeadLetters' to inspect the durable witnesses for one+-- dispatcher. Inserts are idempotent under source-event redelivery.+module Keiro.DeadLetter+  ( DispatcherKind (..),     DispatchDeadLetter (..),     DispatchDeadLetterRecord (..),     recordDispatchDeadLetter,     listDispatchDeadLetters,-)+  ) where  import Effectful (Eff, (:>))-import Keiro.DeadLetter.Schema (-    DispatchDeadLetter (..),+import Keiro.DeadLetter.Schema+  ( DispatchDeadLetter (..),     DispatchDeadLetterRecord (..),     DispatcherKind (..),     listDispatchDeadLettersTx,     recordDispatchDeadLetterTx,- )+  ) import Keiro.Prelude import Kiroku.Store.Effect (Store) import Kiroku.Store.Transaction (runTransaction)
src/Keiro/DeadLetter/Replay.hs view
@@ -1,42 +1,41 @@-{- | Operator replay for source events parked in Kiroku's-@kiroku.dead_letters@ table.--The rows remain Kiroku-owned: replay neither deletes nor marks them. Instead it-re-runs a caller-supplied handler and relies on that handler's idempotency. This-is safe for "Keiro.ProcessManager" and "Keiro.Router" handlers because their-writes use deterministic event identifiers derived from the source event;-already-applied writes collapse to duplicate outcomes on every later replay.--Kiroku exposes dead-letter rows by event id and global position, but does not-currently expose an exact point-read by either value. Global positions are-opaque cursors and must never be decremented. 'replaySubscriptionDeadLetters'-therefore scans the global stream backward using only @0@ and cursors returned-by Kiroku, matches both event id and position, and scans once for the whole-batch. A source event removed by hard deletion is reported as-'ReplaySourceMissing' and is not handed to the caller.--A process-manager handler normally decodes the recorded event, calls-@runProcessManagerOnce@, and classifies a result whose manager state and every-target command are duplicates as 'ReplayedDuplicate'; any append makes it-'ReplayedFresh'. Return @Left detail@ for a decode or command failure. For-example, the classification has this shape:--> case result of->   Left err -> Left (showText err)->   Right pmResult->     | managerAndEveryCommandAreDuplicates pmResult -> Right ReplayedDuplicate->     | otherwise -> Right ReplayedFresh--Because rows are retained, an operator may safely run the same replay command-again after a partial failure or uncertain client disconnect.--}-module Keiro.DeadLetter.Replay (-    ReplayOutcome (..),+-- | Operator replay for source events parked in Kiroku's+-- @kiroku.dead_letters@ table.+--+-- The rows remain Kiroku-owned: replay neither deletes nor marks them. Instead it+-- re-runs a caller-supplied handler and relies on that handler's idempotency. This+-- is safe for "Keiro.ProcessManager" and "Keiro.Router" handlers because their+-- writes use deterministic event identifiers derived from the source event;+-- already-applied writes collapse to duplicate outcomes on every later replay.+--+-- Kiroku exposes dead-letter rows by event id and global position, but does not+-- currently expose an exact point-read by either value. Global positions are+-- opaque cursors and must never be decremented. 'replaySubscriptionDeadLetters'+-- therefore scans the global stream backward using only @0@ and cursors returned+-- by Kiroku, matches both event id and position, and scans once for the whole+-- batch. A source event removed by hard deletion is reported as+-- 'ReplaySourceMissing' and is not handed to the caller.+--+-- A process-manager handler normally decodes the recorded event, calls+-- @runProcessManagerOnce@, and classifies a result whose manager state and every+-- target command are duplicates as 'ReplayedDuplicate'; any append makes it+-- 'ReplayedFresh'. Return @Left detail@ for a decode or command failure. For+-- example, the classification has this shape:+--+-- > case result of+-- >   Left err -> Left (showText err)+-- >   Right pmResult+-- >     | managerAndEveryCommandAreDuplicates pmResult -> Right ReplayedDuplicate+-- >     | otherwise -> Right ReplayedFresh+--+-- Because rows are retained, an operator may safely run the same replay command+-- again after a partial failure or uncertain client disconnect.+module Keiro.DeadLetter.Replay+  ( ReplayOutcome (..),     ReplayResult (..),     DeadLetterRecord (..),     listSubscriptionDeadLetters,     replaySubscriptionDeadLetters,-)+  ) where  import Data.Int (Int32)@@ -55,88 +54,87 @@ import "hasql-transaction" Hasql.Transaction qualified as Tx  data ReplayOutcome = ReplayOutcome-    { replayGlobalPosition :: !GlobalPosition-    , replayEventId :: !EventId-    , replayResult :: !ReplayResult-    }-    deriving stock (Generic, Eq, Show)+  { replayGlobalPosition :: !GlobalPosition,+    replayEventId :: !EventId,+    replayResult :: !ReplayResult+  }+  deriving stock (Generic, Eq, Show)  data ReplayResult-    = ReplayedFresh-    | ReplayedDuplicate-    | ReplayFailed !Text-    | ReplaySourceMissing-    deriving stock (Generic, Eq, Show)+  = ReplayedFresh+  | ReplayedDuplicate+  | ReplayFailed !Text+  | ReplaySourceMissing+  deriving stock (Generic, Eq, Show)  -- | List one Kiroku subscription member's dead letters, newest first. listSubscriptionDeadLetters ::-    (Store :> es) => SubscriptionName -> Int32 -> Eff es (Vector DeadLetterRecord)+  (Store :> es) => SubscriptionName -> Int32 -> Eff es (Vector DeadLetterRecord) listSubscriptionDeadLetters (SubscriptionName name) member =-    runTransaction (Tx.statement (name, member) readDeadLettersStmt)--{- | Replay every dead letter currently listed for one subscription member.+  runTransaction (Tx.statement (name, member) readDeadLettersStmt) -The handler controls domain-specific decoding and decides whether its writes-were fresh or duplicates. A @Left detail@ is recorded in the corresponding-'ReplayOutcome' as 'ReplayFailed'; replay continues with later rows. Store-errors still surface through the surrounding Kiroku 'Store' interpreter.--}+-- | Replay every dead letter currently listed for one subscription member.+--+-- The handler controls domain-specific decoding and decides whether its writes+-- were fresh or duplicates. A @Left detail@ is recorded in the corresponding+-- 'ReplayOutcome' as 'ReplayFailed'; replay continues with later rows. Store+-- errors still surface through the surrounding Kiroku 'Store' interpreter. replaySubscriptionDeadLetters ::-    (Store :> es) =>-    SubscriptionName ->-    Int32 ->-    (RecordedEvent -> Eff es (Either Text ReplayResult)) ->-    Eff es [ReplayOutcome]+  (Store :> es) =>+  SubscriptionName ->+  Int32 ->+  (RecordedEvent -> Eff es (Either Text ReplayResult)) ->+  Eff es [ReplayOutcome] replaySubscriptionDeadLetters subscriptionName member handler = do-    rows <- listSubscriptionDeadLetters subscriptionName member-    sources <- findSources rows-    traverse (replayOne sources) (Vector.toList rows)+  rows <- listSubscriptionDeadLetters subscriptionName member+  sources <- findSources rows+  traverse (replayOne sources) (Vector.toList rows)   where     replayOne sources row = do-        let position = deadLetterPosition row-            eventId = deadLetterEventIdValue row-        result <- case Map.lookup eventId sources of-            Just event-                | event ^. #globalPosition == position -> do-                    handled <- handler event-                    pure (either ReplayFailed id handled)-            _ -> pure ReplaySourceMissing-        pure-            ReplayOutcome-                { replayGlobalPosition = position-                , replayEventId = eventId-                , replayResult = result-                }+      let position = deadLetterPosition row+          eventId = deadLetterEventIdValue row+      result <- case Map.lookup eventId sources of+        Just event+          | event ^. #globalPosition == position -> do+              handled <- handler event+              pure (either ReplayFailed id handled)+        _ -> pure ReplaySourceMissing+      pure+        ReplayOutcome+          { replayGlobalPosition = position,+            replayEventId = eventId,+            replayResult = result+          }  -- Scan once for the complete replay batch. Pages are descending, and the next -- cursor is always a position Kiroku returned; no global-position arithmetic. findSources ::-    (Store :> es) => Vector DeadLetterRecord -> Eff es (Map EventId RecordedEvent)+  (Store :> es) => Vector DeadLetterRecord -> Eff es (Map EventId RecordedEvent) findSources rows = go (GlobalPosition 0) Map.empty   where     wanted =-        Map.fromList-            [ (deadLetterEventIdValue row, deadLetterPosition row)-            | row <- Vector.toList rows-            ]+      Map.fromList+        [ (deadLetterEventIdValue row, deadLetterPosition row)+        | row <- Vector.toList rows+        ]      go cursor found-        | Map.size found == Map.size wanted = pure found-        | otherwise = do-            page <- readAllBackward cursor replayReadPageSize-            if Vector.null page-                then pure found-                else do-                    let found' = Vector.foldl' remember found page-                        nextCursor = Vector.last page ^. #globalPosition-                    go nextCursor found'+      | Map.size found == Map.size wanted = pure found+      | otherwise = do+          page <- readAllBackward cursor replayReadPageSize+          if Vector.null page+            then pure found+            else do+              let found' = Vector.foldl' remember found page+                  nextCursor = Vector.last page ^. #globalPosition+              go nextCursor found'      remember found event =-        case Map.lookup (event ^. #eventId) wanted of-            Just expectedPosition-                | event ^. #globalPosition == expectedPosition ->-                    Map.insert (event ^. #eventId) event found-            _ -> found+      case Map.lookup (event ^. #eventId) wanted of+        Just expectedPosition+          | event ^. #globalPosition == expectedPosition ->+              Map.insert (event ^. #eventId) event found+        _ -> found  replayReadPageSize :: Int32 replayReadPageSize = 256
src/Keiro/DeadLetter/Schema.hs view
@@ -1,18 +1,17 @@-{- | SQL storage for rejected process-manager and router dispatches.--The @keiro.keiro_dead_letters@ table records a dispatched command that a-target state machine rejected. It is deliberately separate from Kiroku's-subscription dead-letter table: a row here describes one failed dispatch,-while the source subscription event is considered handled and may advance its-checkpoint.--}-module Keiro.DeadLetter.Schema (-    DispatcherKind (..),+-- | SQL storage for rejected process-manager and router dispatches.+--+-- The @keiro.keiro_dead_letters@ table records a dispatched command that a+-- target state machine rejected. It is deliberately separate from Kiroku's+-- subscription dead-letter table: a row here describes one failed dispatch,+-- while the source subscription event is considered handled and may advance its+-- checkpoint.+module Keiro.DeadLetter.Schema+  ( DispatcherKind (..),     DispatchDeadLetter (..),     DispatchDeadLetterRecord (..),     recordDispatchDeadLetterTx,     listDispatchDeadLettersTx,-)+  ) where  import Contravariant.Extras (contrazip10)@@ -29,137 +28,136 @@  -- | Which coordination primitive attempted the rejected dispatch. data DispatcherKind-    = DispatcherProcessManager-    | DispatcherRouter-    deriving stock (Generic, Eq, Ord, Show)+  = DispatcherProcessManager+  | DispatcherRouter+  deriving stock (Generic, Eq, Ord, Show)  -- | Fields persisted for one rejected dispatch. data DispatchDeadLetter = DispatchDeadLetter-    { dispatcherKind :: !DispatcherKind-    , dispatcherName :: !Text-    , correlationId :: !Text-    , sourceEventId :: !EventId-    , sourceGlobalPosition :: !GlobalPosition-    , emitIndex :: !Int-    , targetStreamName :: !StreamName-    , errorClass :: !Text-    , errorDetail :: !Text-    , attemptCount :: !Int-    }-    deriving stock (Generic, Eq, Show)+  { dispatcherKind :: !DispatcherKind,+    dispatcherName :: !Text,+    correlationId :: !Text,+    sourceEventId :: !EventId,+    sourceGlobalPosition :: !GlobalPosition,+    emitIndex :: !Int,+    targetStreamName :: !StreamName,+    errorClass :: !Text,+    errorDetail :: !Text,+    attemptCount :: !Int+  }+  deriving stock (Generic, Eq, Show)  -- | A persisted rejected dispatch, including database-managed identity and time. data DispatchDeadLetterRecord = DispatchDeadLetterRecord-    { deadLetterId :: !Int64-    , dispatcherKind :: !DispatcherKind-    , dispatcherName :: !Text-    , correlationId :: !Text-    , sourceEventId :: !EventId-    , sourceGlobalPosition :: !GlobalPosition-    , emitIndex :: !Int-    , targetStreamName :: !StreamName-    , errorClass :: !Text-    , errorDetail :: !Text-    , attemptCount :: !Int-    , createdAt :: !UTCTime-    }-    deriving stock (Generic, Eq, Show)+  { deadLetterId :: !Int64,+    dispatcherKind :: !DispatcherKind,+    dispatcherName :: !Text,+    correlationId :: !Text,+    sourceEventId :: !EventId,+    sourceGlobalPosition :: !GlobalPosition,+    emitIndex :: !Int,+    targetStreamName :: !StreamName,+    errorClass :: !Text,+    errorDetail :: !Text,+    attemptCount :: !Int,+    createdAt :: !UTCTime+  }+  deriving stock (Generic, Eq, Show) -{- | Insert a rejected dispatch inside the caller's transaction. Redelivery is-idempotent: a duplicate @(dispatcher_name, source_event_id, emit_index)@ is a-no-op. Error detail is bounded here so every caller gets the same 1024-character-storage contract.--}+-- | Insert a rejected dispatch inside the caller's transaction. Redelivery is+-- idempotent: a duplicate @(dispatcher_name, source_event_id, emit_index)@ is a+-- no-op. Error detail is bounded here so every caller gets the same 1024-character+-- storage contract. recordDispatchDeadLetterTx :: DispatchDeadLetter -> Tx.Transaction () recordDispatchDeadLetterTx deadLetter =-    Tx.statement (dispatchDeadLetterParams deadLetter) insertDispatchDeadLetterStmt+  Tx.statement (dispatchDeadLetterParams deadLetter) insertDispatchDeadLetterStmt  -- | List one dispatcher's records, newest first. listDispatchDeadLettersTx :: Text -> Tx.Transaction [DispatchDeadLetterRecord] listDispatchDeadLettersTx dispatcher =-    Tx.statement dispatcher listDispatchDeadLettersStmt+  Tx.statement dispatcher listDispatchDeadLettersStmt  insertDispatchDeadLetterStmt :: Statement (Text, Text, Text, UUID, Int64, Int32, Text, Text, Text, Int32) () insertDispatchDeadLetterStmt =-    preparable-        """-        INSERT INTO keiro.keiro_dead_letters-          (dispatcher_kind, dispatcher_name, correlation_id, source_event_id,-           source_global_position, emit_index, target_stream_name, error_class,-           error_detail, attempt_count)-        VALUES-          ($1, $2, $3, $4, $5, $6, $7, $8, $9, $10)-        ON CONFLICT (dispatcher_name, source_event_id, emit_index) DO NOTHING-        """-        ( contrazip10-            (E.param (E.nonNullable E.text))-            (E.param (E.nonNullable E.text))-            (E.param (E.nonNullable E.text))-            (E.param (E.nonNullable E.uuid))-            (E.param (E.nonNullable E.int8))-            (E.param (E.nonNullable E.int4))-            (E.param (E.nonNullable E.text))-            (E.param (E.nonNullable E.text))-            (E.param (E.nonNullable E.text))-            (E.param (E.nonNullable E.int4))-        )-        D.noResult+  preparable+    """+    INSERT INTO keiro.keiro_dead_letters+      (dispatcher_kind, dispatcher_name, correlation_id, source_event_id,+       source_global_position, emit_index, target_stream_name, error_class,+       error_detail, attempt_count)+    VALUES+      ($1, $2, $3, $4, $5, $6, $7, $8, $9, $10)+    ON CONFLICT (dispatcher_name, source_event_id, emit_index) DO NOTHING+    """+    ( contrazip10+        (E.param (E.nonNullable E.text))+        (E.param (E.nonNullable E.text))+        (E.param (E.nonNullable E.text))+        (E.param (E.nonNullable E.uuid))+        (E.param (E.nonNullable E.int8))+        (E.param (E.nonNullable E.int4))+        (E.param (E.nonNullable E.text))+        (E.param (E.nonNullable E.text))+        (E.param (E.nonNullable E.text))+        (E.param (E.nonNullable E.int4))+    )+    D.noResult  listDispatchDeadLettersStmt :: Statement Text [DispatchDeadLetterRecord] listDispatchDeadLettersStmt =-    preparable-        """-        SELECT dead_letter_id, dispatcher_kind, dispatcher_name, correlation_id,-               source_event_id, source_global_position, emit_index,-               target_stream_name, error_class, error_detail, attempt_count,-               created_at-        FROM keiro.keiro_dead_letters-        WHERE dispatcher_name = $1-        ORDER BY created_at DESC, dead_letter_id DESC-        """-        (E.param (E.nonNullable E.text))-        (D.rowList dispatchDeadLetterRecordDecoder)+  preparable+    """+    SELECT dead_letter_id, dispatcher_kind, dispatcher_name, correlation_id,+           source_event_id, source_global_position, emit_index,+           target_stream_name, error_class, error_detail, attempt_count,+           created_at+    FROM keiro.keiro_dead_letters+    WHERE dispatcher_name = $1+    ORDER BY created_at DESC, dead_letter_id DESC+    """+    (E.param (E.nonNullable E.text))+    (D.rowList dispatchDeadLetterRecordDecoder)  dispatchDeadLetterRecordDecoder :: D.Row DispatchDeadLetterRecord dispatchDeadLetterRecordDecoder =-    DispatchDeadLetterRecord-        <$> D.column (D.nonNullable D.int8)-        <*> D.column (D.nonNullable (D.refine dispatcherKindFromText D.text))-        <*> D.column (D.nonNullable D.text)-        <*> D.column (D.nonNullable D.text)-        <*> (EventId <$> D.column (D.nonNullable D.uuid))-        <*> (GlobalPosition <$> D.column (D.nonNullable D.int8))-        <*> (fromIntegral <$> D.column (D.nonNullable D.int4))-        <*> (StreamName <$> D.column (D.nonNullable D.text))-        <*> D.column (D.nonNullable D.text)-        <*> D.column (D.nonNullable D.text)-        <*> (fromIntegral <$> D.column (D.nonNullable D.int4))-        <*> D.column (D.nonNullable D.timestamptz)+  DispatchDeadLetterRecord+    <$> D.column (D.nonNullable D.int8)+    <*> D.column (D.nonNullable (D.refine dispatcherKindFromText D.text))+    <*> D.column (D.nonNullable D.text)+    <*> D.column (D.nonNullable D.text)+    <*> (EventId <$> D.column (D.nonNullable D.uuid))+    <*> (GlobalPosition <$> D.column (D.nonNullable D.int8))+    <*> (fromIntegral <$> D.column (D.nonNullable D.int4))+    <*> (StreamName <$> D.column (D.nonNullable D.text))+    <*> D.column (D.nonNullable D.text)+    <*> D.column (D.nonNullable D.text)+    <*> (fromIntegral <$> D.column (D.nonNullable D.int4))+    <*> D.column (D.nonNullable D.timestamptz)  dispatchDeadLetterParams :: DispatchDeadLetter -> (Text, Text, Text, UUID, Int64, Int32, Text, Text, Text, Int32) dispatchDeadLetterParams deadLetter =-    ( dispatcherKindToText (deadLetter ^. #dispatcherKind)-    , deadLetter ^. #dispatcherName-    , deadLetter ^. #correlationId-    , eventIdToUuid (deadLetter ^. #sourceEventId)-    , globalPositionToInt64 (deadLetter ^. #sourceGlobalPosition)-    , fromIntegral (deadLetter ^. #emitIndex)-    , streamNameToText (deadLetter ^. #targetStreamName)-    , deadLetter ^. #errorClass-    , Text.take 1024 (deadLetter ^. #errorDetail)-    , fromIntegral (deadLetter ^. #attemptCount)-    )+  ( dispatcherKindToText (deadLetter ^. #dispatcherKind),+    deadLetter ^. #dispatcherName,+    deadLetter ^. #correlationId,+    eventIdToUuid (deadLetter ^. #sourceEventId),+    globalPositionToInt64 (deadLetter ^. #sourceGlobalPosition),+    fromIntegral (deadLetter ^. #emitIndex),+    streamNameToText (deadLetter ^. #targetStreamName),+    deadLetter ^. #errorClass,+    Text.take 1024 (deadLetter ^. #errorDetail),+    fromIntegral (deadLetter ^. #attemptCount)+  )  dispatcherKindToText :: DispatcherKind -> Text dispatcherKindToText = \case-    DispatcherProcessManager -> "process-manager"-    DispatcherRouter -> "router"+  DispatcherProcessManager -> "process-manager"+  DispatcherRouter -> "router"  dispatcherKindFromText :: Text -> Either Text DispatcherKind dispatcherKindFromText = \case-    "process-manager" -> Right DispatcherProcessManager-    "router" -> Right DispatcherRouter-    other -> Left ("unknown keiro_dead_letters.dispatcher_kind: " <> other)+  "process-manager" -> Right DispatcherProcessManager+  "router" -> Right DispatcherRouter+  other -> Left ("unknown keiro_dead_letters.dispatcher_kind: " <> other)  eventIdToUuid :: EventId -> UUID eventIdToUuid (EventId uuid) = uuid
src/Keiro/Inbox.hs view
@@ -1,28 +1,27 @@-{- | Idempotent inbox for cross-bounded-context integration events.--The inbox lives in the consuming bounded context. When a Kafka consumer-receives an integration event, the inbox records the event's stable-external identity and runs the local handler in the same Postgres-transaction. Duplicate redeliveries (Kafka offset retry, rebalance,-producer republish) become observable as duplicates instead of-re-running the handler.--The wrapper is a single-transaction primitive: the completed inbox row-and the handler's local writes commit atomically. If the handler raises-or condemns the transaction, the inbox row never appears and the next-delivery starts fresh.--Completed-row retention defines the deduplication window. After-'garbageCollectCompleted' removes a row, a later delivery of the same key is-processed again. A concurrent GC can also delete a conflicting completed row-between the insert attempt and its lookup; the handler then commits without a-replacement deduplication row, so a later redelivery can run it again. These-cases preserve at-least-once delivery, not permanent exactly-once processing;-size retention beyond the maximum redelivery delay and keep handlers-idempotent.--}-module Keiro.Inbox (-    -- * Re-exports+-- | Idempotent inbox for cross-bounded-context integration events.+--+-- The inbox lives in the consuming bounded context. When a Kafka consumer+-- receives an integration event, the inbox records the event's stable+-- external identity and runs the local handler in the same Postgres+-- transaction. Duplicate redeliveries (Kafka offset retry, rebalance,+-- producer republish) become observable as duplicates instead of+-- re-running the handler.+--+-- The wrapper is a single-transaction primitive: the completed inbox row+-- and the handler's local writes commit atomically. If the handler raises+-- or condemns the transaction, the inbox row never appears and the next+-- delivery starts fresh.+--+-- Completed-row retention defines the deduplication window. After+-- 'garbageCollectCompleted' removes a row, a later delivery of the same key is+-- processed again. A concurrent GC can also delete a conflicting completed row+-- between the insert attempt and its lookup; the handler then commits without a+-- replacement deduplication row, so a later redelivery can run it again. These+-- cases preserve at-least-once delivery, not permanent exactly-once processing;+-- size retention beyond the maximum redelivery delay and keep handlers+-- idempotent.+module Keiro.Inbox+  ( -- * Re-exports     module Keiro.Inbox.Types,      -- * Storage primitives@@ -41,7 +40,7 @@     runInboxTransactionWithRetriesKey,     runInboxTransactionBatch,     sampleInboxBacklog,-)+  ) where  import Data.Map.Strict qualified as Map@@ -53,374 +52,368 @@ import Keiro.Inbox.Types import Keiro.Integration.Event (IntegrationEvent) import Keiro.Prelude-import Keiro.Telemetry (-    KeiroMetrics,+import Keiro.Telemetry+  ( KeiroMetrics,     recordInboxBacklog,     recordInboxDuplicates,     recordInboxFailed,     recordInboxPoisoned,     recordInboxProcessed,- )+  ) import Kiroku.Store.Effect (Store) import Kiroku.Store.Transaction (runTransaction) import "hasql-transaction" Hasql.Transaction qualified as Tx  data BatchPlan-    = BatchKeyError !InboxError-    | BatchDuplicate-    | BatchWork !Text !Text !IntegrationEvent !(Maybe KafkaDeliveryRef)--{- | Run @handler@ at most once for each @(source, dedupe_key)@.--Computes the dedupe key from @policy@ and @kafka@, then in one-transaction:--* Inserts the inbox row with status @completed@.-* If the row already exists, branches on its status: 'InboxCompleted'-  → 'InboxDuplicate'; 'InboxProcessing' → 'InboxInProgress';-  'InboxFailed' → 'InboxPreviouslyFailed'.-* Otherwise runs @handler@; the row commits only if the handler succeeds.+  = BatchKeyError !InboxError+  | BatchDuplicate+  | BatchWork !Text !Text !IntegrationEvent !(Maybe KafkaDeliveryRef) -The handler is invoked with the decoded 'IntegrationEvent' so it does-not need to redecode bytes. On exception or 'Tx.condemn' the whole-transaction rolls back, including the inbox row insert — the next-delivery sees no row and can retry.--}+-- | Run @handler@ at most once for each @(source, dedupe_key)@.+--+-- Computes the dedupe key from @policy@ and @kafka@, then in one+-- transaction:+--+-- * Inserts the inbox row with status @completed@.+-- * If the row already exists, branches on its status: 'InboxCompleted'+--   → 'InboxDuplicate'; 'InboxProcessing' → 'InboxInProgress';+--   'InboxFailed' → 'InboxPreviouslyFailed'.+-- * Otherwise runs @handler@; the row commits only if the handler succeeds.+--+-- The handler is invoked with the decoded 'IntegrationEvent' so it does+-- not need to redecode bytes. On exception or 'Tx.condemn' the whole+-- transaction rolls back, including the inbox row insert — the next+-- delivery sees no row and can retry. runInboxTransaction ::-    forall a es.-    (IOE :> es, Store :> es) =>-    Maybe KeiroMetrics ->-    InboxDedupePolicy ->-    IntegrationEvent ->-    Maybe KafkaDeliveryRef ->-    (IntegrationEvent -> Tx.Transaction a) ->-    Eff es (Either InboxError (InboxResult a))+  forall a es.+  (IOE :> es, Store :> es) =>+  Maybe KeiroMetrics ->+  InboxDedupePolicy ->+  IntegrationEvent ->+  Maybe KafkaDeliveryRef ->+  (IntegrationEvent -> Tx.Transaction a) ->+  Eff es (Either InboxError (InboxResult a)) runInboxTransaction mMetrics policy event kafka handler =-    runInboxTransactionWith mMetrics PersistFullEnvelope policy event kafka handler--{- | Variant of 'runInboxTransaction' that controls success-path-envelope persistence.+  runInboxTransactionWith mMetrics PersistFullEnvelope policy event kafka handler -'PersistDedupeOnly' keeps enough columns for dedupe and operator-correlation but stores an empty payload and omits schema, trace, and-attribute columns for successfully processed rows.--}+-- | Variant of 'runInboxTransaction' that controls success-path+-- envelope persistence.+--+-- 'PersistDedupeOnly' keeps enough columns for dedupe and operator+-- correlation but stores an empty payload and omits schema, trace, and+-- attribute columns for successfully processed rows. runInboxTransactionWith ::-    forall a es.-    (IOE :> es, Store :> es) =>-    Maybe KeiroMetrics ->-    InboxPersistence ->-    InboxDedupePolicy ->-    IntegrationEvent ->-    Maybe KafkaDeliveryRef ->-    (IntegrationEvent -> Tx.Transaction a) ->-    Eff es (Either InboxError (InboxResult a))+  forall a es.+  (IOE :> es, Store :> es) =>+  Maybe KeiroMetrics ->+  InboxPersistence ->+  InboxDedupePolicy ->+  IntegrationEvent ->+  Maybe KafkaDeliveryRef ->+  (IntegrationEvent -> Tx.Transaction a) ->+  Eff es (Either InboxError (InboxResult a)) runInboxTransactionWith mMetrics persistence policy event kafka handler =-    case dedupeKeyFor policy event kafka of-        Left err -> pure (Left err)-        Right dedupe ->-            Right-                <$> runInboxTransactionWithKeyPersist-                    mMetrics-                    persistence-                    (event ^. #source)-                    dedupe-                    event-                    kafka-                    handler--{- | Lower-level variant that takes the dedupe key directly.+  case dedupeKeyFor policy event kafka of+    Left err -> pure (Left err)+    Right dedupe ->+      Right+        <$> runInboxTransactionWithKeyPersist+          mMetrics+          persistence+          (event ^. #source)+          dedupe+          event+          kafka+          handler -Use when the policy is not enough to express the identity scheme — for-example, when the consumer joins fields from multiple headers or-derives the key from the payload itself.--}+-- | Lower-level variant that takes the dedupe key directly.+--+-- Use when the policy is not enough to express the identity scheme — for+-- example, when the consumer joins fields from multiple headers or+-- derives the key from the payload itself. runInboxTransactionWithKey ::-    forall a es.-    (IOE :> es, Store :> es) =>-    Maybe KeiroMetrics ->-    Text ->-    Text ->-    IntegrationEvent ->-    Maybe KafkaDeliveryRef ->-    (IntegrationEvent -> Tx.Transaction a) ->-    Eff es (InboxResult a)+  forall a es.+  (IOE :> es, Store :> es) =>+  Maybe KeiroMetrics ->+  Text ->+  Text ->+  IntegrationEvent ->+  Maybe KafkaDeliveryRef ->+  (IntegrationEvent -> Tx.Transaction a) ->+  Eff es (InboxResult a) runInboxTransactionWithKey mMetrics src dedupe event kafka handler =-    runInboxTransactionWithKeyPersist mMetrics PersistFullEnvelope src dedupe event kafka handler+  runInboxTransactionWithKeyPersist mMetrics PersistFullEnvelope src dedupe event kafka handler  runInboxTransactionWithKeyPersist ::-    forall a es.-    (IOE :> es, Store :> es) =>-    Maybe KeiroMetrics ->-    InboxPersistence ->-    Text ->-    Text ->-    IntegrationEvent ->-    Maybe KafkaDeliveryRef ->-    (IntegrationEvent -> Tx.Transaction a) ->-    Eff es (InboxResult a)+  forall a es.+  (IOE :> es, Store :> es) =>+  Maybe KeiroMetrics ->+  InboxPersistence ->+  Text ->+  Text ->+  IntegrationEvent ->+  Maybe KafkaDeliveryRef ->+  (IntegrationEvent -> Tx.Transaction a) ->+  Eff es (InboxResult a) runInboxTransactionWithKeyPersist mMetrics persistence src dedupe event kafka handler = do-    now <- liftIO getCurrentTime-    result <--        runTransaction $-            attemptOneTx persistence Nothing src dedupe event kafka now handler-    -- Record the classification counter outside the handler transaction.-    -- Backlog gauge sampling is intentionally scheduled separately via-    -- 'sampleInboxBacklog'.-    recordInboxResult mMetrics Nothing result-    pure result--{- | Run @handler@ with opt-in poison-message accounting.--This wrapper behaves like 'runInboxTransaction' for fresh messages,-duplicates, and in-flight rows, but changes the behavior for handler-exceptions and previously failed rows:--* A synchronous exception from @handler@ rolls back the handler-  transaction, then records a failed attempt in a second transaction and-  returns 'InboxHandlerFailed' with the new attempt count.-* A previously failed row with @attempt_count < ceiling@ is retried.-* A previously failed row with @attempt_count >= ceiling@ returns-  'InboxPreviouslyFailed' without running the handler. The consumer can-  commit its offset and move on; the failed inbox row is the dead-letter-  record for operator review.+  now <- liftIO getCurrentTime+  result <-+    runTransaction $+      attemptOneTx persistence Nothing src dedupe event kafka now handler+  -- Record the classification counter outside the handler transaction.+  -- Backlog gauge sampling is intentionally scheduled separately via+  -- 'sampleInboxBacklog'.+  recordInboxResult mMetrics Nothing result+  pure result -'Tx.condemn' is not treated as a handler failure by this wrapper. It-keeps the original rollback semantics from 'runInboxTransaction'.--}+-- | Run @handler@ with opt-in poison-message accounting.+--+-- This wrapper behaves like 'runInboxTransaction' for fresh messages,+-- duplicates, and in-flight rows, but changes the behavior for handler+-- exceptions and previously failed rows:+--+-- * A synchronous exception from @handler@ rolls back the handler+--   transaction, then records a failed attempt in a second transaction and+--   returns 'InboxHandlerFailed' with the new attempt count.+-- * A previously failed row with @attempt_count < ceiling@ is retried.+-- * A previously failed row with @attempt_count >= ceiling@ returns+--   'InboxPreviouslyFailed' without running the handler. The consumer can+--   commit its offset and move on; the failed inbox row is the dead-letter+--   record for operator review.+--+-- 'Tx.condemn' is not treated as a handler failure by this wrapper. It+-- keeps the original rollback semantics from 'runInboxTransaction'. runInboxTransactionWithRetries ::-    forall a es.-    (IOE :> es, Store :> es) =>-    Maybe KeiroMetrics ->-    Int ->-    InboxDedupePolicy ->-    IntegrationEvent ->-    Maybe KafkaDeliveryRef ->-    (IntegrationEvent -> Tx.Transaction a) ->-    Eff es (Either InboxError (InboxResult a))+  forall a es.+  (IOE :> es, Store :> es) =>+  Maybe KeiroMetrics ->+  Int ->+  InboxDedupePolicy ->+  IntegrationEvent ->+  Maybe KafkaDeliveryRef ->+  (IntegrationEvent -> Tx.Transaction a) ->+  Eff es (Either InboxError (InboxResult a)) runInboxTransactionWithRetries mMetrics attemptCeiling policy event kafka handler =-    runInboxTransactionWithRetriesWith mMetrics attemptCeiling PersistFullEnvelope policy event kafka handler+  runInboxTransactionWithRetriesWith mMetrics attemptCeiling PersistFullEnvelope policy event kafka handler  -- | Variant of 'runInboxTransactionWithRetries' that controls success-path persistence. runInboxTransactionWithRetriesWith ::-    forall a es.-    (IOE :> es, Store :> es) =>-    Maybe KeiroMetrics ->-    Int ->-    InboxPersistence ->-    InboxDedupePolicy ->-    IntegrationEvent ->-    Maybe KafkaDeliveryRef ->-    (IntegrationEvent -> Tx.Transaction a) ->-    Eff es (Either InboxError (InboxResult a))+  forall a es.+  (IOE :> es, Store :> es) =>+  Maybe KeiroMetrics ->+  Int ->+  InboxPersistence ->+  InboxDedupePolicy ->+  IntegrationEvent ->+  Maybe KafkaDeliveryRef ->+  (IntegrationEvent -> Tx.Transaction a) ->+  Eff es (Either InboxError (InboxResult a)) runInboxTransactionWithRetriesWith mMetrics attemptCeiling persistence policy event kafka handler =-    case dedupeKeyFor policy event kafka of-        Left err -> pure (Left err)-        Right dedupe ->-            Right-                <$> runInboxTransactionWithRetriesKeyPersist-                    mMetrics-                    attemptCeiling-                    persistence-                    (event ^. #source)-                    dedupe-                    event-                    kafka-                    handler+  case dedupeKeyFor policy event kafka of+    Left err -> pure (Left err)+    Right dedupe ->+      Right+        <$> runInboxTransactionWithRetriesKeyPersist+          mMetrics+          attemptCeiling+          persistence+          (event ^. #source)+          dedupe+          event+          kafka+          handler  -- | Lower-level retrying variant that takes the dedupe key directly. runInboxTransactionWithRetriesKey ::-    forall a es.-    (IOE :> es, Store :> es) =>-    Maybe KeiroMetrics ->-    Int ->-    Text ->-    Text ->-    IntegrationEvent ->-    Maybe KafkaDeliveryRef ->-    (IntegrationEvent -> Tx.Transaction a) ->-    Eff es (InboxResult a)+  forall a es.+  (IOE :> es, Store :> es) =>+  Maybe KeiroMetrics ->+  Int ->+  Text ->+  Text ->+  IntegrationEvent ->+  Maybe KafkaDeliveryRef ->+  (IntegrationEvent -> Tx.Transaction a) ->+  Eff es (InboxResult a) runInboxTransactionWithRetriesKey mMetrics attemptCeiling src dedupe event kafka handler =-    runInboxTransactionWithRetriesKeyPersist mMetrics attemptCeiling PersistFullEnvelope src dedupe event kafka handler+  runInboxTransactionWithRetriesKeyPersist mMetrics attemptCeiling PersistFullEnvelope src dedupe event kafka handler  runInboxTransactionWithRetriesKeyPersist ::-    forall a es.-    (IOE :> es, Store :> es) =>-    Maybe KeiroMetrics ->-    Int ->-    InboxPersistence ->-    Text ->-    Text ->-    IntegrationEvent ->-    Maybe KafkaDeliveryRef ->-    (IntegrationEvent -> Tx.Transaction a) ->-    Eff es (InboxResult a)+  forall a es.+  (IOE :> es, Store :> es) =>+  Maybe KeiroMetrics ->+  Int ->+  InboxPersistence ->+  Text ->+  Text ->+  IntegrationEvent ->+  Maybe KafkaDeliveryRef ->+  (IntegrationEvent -> Tx.Transaction a) ->+  Eff es (InboxResult a) runInboxTransactionWithRetriesKeyPersist mMetrics attemptCeiling persistence src dedupe event kafka handler = do-    now <- liftIO getCurrentTime-    attempted <--        trySync $-            runTransaction $-                attemptOneTx persistence (Just attemptCeiling) src dedupe event kafka now handler-    result <- case attempted of-        Right ok -> pure ok-        Left err -> do-            failedAt <- liftIO getCurrentTime-            let errMsg = Text.pack (displayException err)-            attempts <--                runTransaction $-                    recordFailedAttemptTx src dedupe event kafka errMsg failedAt-            pure (InboxHandlerFailed errMsg attempts)-    recordInboxResult mMetrics (Just attemptCeiling) result-    pure result--{- | Process a batch of inbox deliveries with a single transactional fast path.--The fast path computes each @(source, dedupe_key)@, suppresses repeated-keys within the batch as duplicates, then runs all remaining deliveries-in one Postgres transaction. If any handler throws or condemns that-transaction, the whole batch rolls back and every original delivery is-retried through 'runInboxTransactionWithRetries'. That fallback preserves-per-message failure accounting and prevents one poison message from-discarding unrelated batch mates.+  now <- liftIO getCurrentTime+  attempted <-+    trySync $+      runTransaction $+        attemptOneTx persistence (Just attemptCeiling) src dedupe event kafka now handler+  result <- case attempted of+    Right ok -> pure ok+    Left err -> do+      failedAt <- liftIO getCurrentTime+      let errMsg = Text.pack (displayException err)+      attempts <-+        runTransaction $+          recordFailedAttemptTx src dedupe event kafka errMsg failedAt+      pure (InboxHandlerFailed errMsg attempts)+  recordInboxResult mMetrics (Just attemptCeiling) result+  pure result -'Tx.condemn' rolls the transaction back at commit but returns normally,-so it cannot be observed from the transaction's return value alone.-The batch detects it by re-reading one row it should have committed:-every write in the fast path belongs to a delivery classified-'InboxProcessed' (fresh insert as @completed@ or retry promotion to-@completed@), so if the first such row is not @completed@ after the-transaction returns, the whole batch was condemned and the per-message-fallback runs. A batch with no 'InboxProcessed' rows performed no writes,-so a condemned transaction loses nothing.--}+-- | Process a batch of inbox deliveries with a single transactional fast path.+--+-- The fast path computes each @(source, dedupe_key)@, suppresses repeated+-- keys within the batch as duplicates, then runs all remaining deliveries+-- in one Postgres transaction. If any handler throws or condemns that+-- transaction, the whole batch rolls back and every original delivery is+-- retried through 'runInboxTransactionWithRetries'. That fallback preserves+-- per-message failure accounting and prevents one poison message from+-- discarding unrelated batch mates.+--+-- 'Tx.condemn' rolls the transaction back at commit but returns normally,+-- so it cannot be observed from the transaction's return value alone.+-- The batch detects it by re-reading one row it should have committed:+-- every write in the fast path belongs to a delivery classified+-- 'InboxProcessed' (fresh insert as @completed@ or retry promotion to+-- @completed@), so if the first such row is not @completed@ after the+-- transaction returns, the whole batch was condemned and the per-message+-- fallback runs. A batch with no 'InboxProcessed' rows performed no writes,+-- so a condemned transaction loses nothing. runInboxTransactionBatch ::-    forall a es.-    (IOE :> es, Store :> es) =>-    Maybe KeiroMetrics ->-    Int ->-    InboxDedupePolicy ->-    InboxPersistence ->-    [(IntegrationEvent, Maybe KafkaDeliveryRef)] ->-    (IntegrationEvent -> Tx.Transaction a) ->-    Eff es [Either InboxError (InboxResult a)]+  forall a es.+  (IOE :> es, Store :> es) =>+  Maybe KeiroMetrics ->+  Int ->+  InboxDedupePolicy ->+  InboxPersistence ->+  [(IntegrationEvent, Maybe KafkaDeliveryRef)] ->+  (IntegrationEvent -> Tx.Transaction a) ->+  Eff es [Either InboxError (InboxResult a)] runInboxTransactionBatch mMetrics attemptCeiling policy persistence deliveries handler = do-    now <- liftIO getCurrentTime-    let plan = planInboxBatch policy deliveries-    attempted <--        trySync $-            runTransaction $-                traverse-                    ( \case-                        BatchKeyError err -> pure (Left err)-                        BatchDuplicate -> pure (Right InboxDuplicate)-                        BatchWork src dedupe event kafka ->-                            Right <$> attemptOneTx persistence (Just attemptCeiling) src dedupe event kafka now handler-                    )-                    plan-    case attempted of-        Right results -> do-            committed <- verifyBatchCommitted plan results-            if committed-                then do-                    for_ results $ \case-                        Right result -> recordInboxResult mMetrics (Just attemptCeiling) result-                        Left _ -> pure ()-                    pure results-                else perMessageFallback-        Left _ -> perMessageFallback+  now <- liftIO getCurrentTime+  let plan = planInboxBatch policy deliveries+  attempted <-+    trySync $+      runTransaction $+        traverse+          ( \case+              BatchKeyError err -> pure (Left err)+              BatchDuplicate -> pure (Right InboxDuplicate)+              BatchWork src dedupe event kafka ->+                Right <$> attemptOneTx persistence (Just attemptCeiling) src dedupe event kafka now handler+          )+          plan+  case attempted of+    Right results -> do+      committed <- verifyBatchCommitted plan results+      if committed+        then do+          for_ results $ \case+            Right result -> recordInboxResult mMetrics (Just attemptCeiling) result+            Left _ -> pure ()+          pure results+        else perMessageFallback+    Left _ -> perMessageFallback   where     perMessageFallback :: Eff es [Either InboxError (InboxResult a)]     perMessageFallback =-        traverse-            ( \(event, kafka) ->-                runInboxTransactionWithRetriesWith mMetrics attemptCeiling persistence policy event kafka handler-            )-            deliveries+      traverse+        ( \(event, kafka) ->+            runInboxTransactionWithRetriesWith mMetrics attemptCeiling persistence policy event kafka handler+        )+        deliveries      -- A condemned transaction returns its results normally but commits     -- nothing. Re-read the first row the batch claims to have completed;     -- if it is not @completed@, the transaction rolled back at commit.     verifyBatchCommitted ::-        [BatchPlan] ->-        [Either InboxError (InboxResult a)] ->-        Eff es Bool+      [BatchPlan] ->+      [Either InboxError (InboxResult a)] ->+      Eff es Bool     verifyBatchCommitted plan results =-        case listToMaybe (mapMaybe processedKey (zip plan results)) of-            Nothing -> pure True-            Just (src, dedupe) -> do-                row <- lookupInbox src dedupe-                pure (fmap (^. #status) row == Just InboxCompleted)+      case listToMaybe (mapMaybe processedKey (zip plan results)) of+        Nothing -> pure True+        Just (src, dedupe) -> do+          row <- lookupInbox src dedupe+          pure (fmap (^. #status) row == Just InboxCompleted)      processedKey :: (BatchPlan, Either InboxError (InboxResult a)) -> Maybe (Text, Text)     processedKey = \case-        (BatchWork src dedupe _ _, Right (InboxProcessed _)) -> Just (src, dedupe)-        _ -> Nothing+      (BatchWork src dedupe _ _, Right (InboxProcessed _)) -> Just (src, dedupe)+      _ -> Nothing  attemptOneTx ::-    InboxPersistence ->-    Maybe Int ->-    Text ->-    Text ->-    IntegrationEvent ->-    Maybe KafkaDeliveryRef ->-    UTCTime ->-    (IntegrationEvent -> Tx.Transaction a) ->-    Tx.Transaction (InboxResult a)+  InboxPersistence ->+  Maybe Int ->+  Text ->+  Text ->+  IntegrationEvent ->+  Maybe KafkaDeliveryRef ->+  UTCTime ->+  (IntegrationEvent -> Tx.Transaction a) ->+  Tx.Transaction (InboxResult a) attemptOneTx persistence attemptCeiling src dedupe event kafka now handler = do-    inserted <- tryInsertCompletedTx persistence src dedupe event kafka now-    case inserted of-        Right () -> do-            handled <- handler event-            pure (InboxProcessed handled)-        Left row -> case row ^. #status of-            InboxCompleted -> pure InboxDuplicate-            InboxProcessing -> pure InboxInProgress-            InboxFailed -> case attemptCeiling of-                Nothing -> pure (InboxPreviouslyFailed (row ^. #lastError))-                Just attemptLimit-                    | row ^. #attemptCount >= attemptLimit ->-                        pure (InboxPreviouslyFailed (row ^. #lastError))-                    | otherwise -> do-                        handled <- handler event-                        markCompletedTx src dedupe now-                        pure (InboxProcessed handled)+  inserted <- tryInsertCompletedTx persistence src dedupe event kafka now+  case inserted of+    Right () -> do+      handled <- handler event+      pure (InboxProcessed handled)+    Left row -> case row ^. #status of+      InboxCompleted -> pure InboxDuplicate+      InboxProcessing -> pure InboxInProgress+      InboxFailed -> case attemptCeiling of+        Nothing -> pure (InboxPreviouslyFailed (row ^. #lastError))+        Just attemptLimit+          | row ^. #attemptCount >= attemptLimit ->+              pure (InboxPreviouslyFailed (row ^. #lastError))+          | otherwise -> do+              handled <- handler event+              markCompletedTx src dedupe now+              pure (InboxProcessed handled)  recordInboxResult :: (IOE :> es) => Maybe KeiroMetrics -> Maybe Int -> InboxResult a -> Eff es () recordInboxResult mMetrics attemptCeiling = \case-    InboxProcessed _ -> recordInboxProcessed mMetrics 1-    InboxDuplicate -> recordInboxDuplicates mMetrics 1-    InboxPreviouslyFailed _ -> recordInboxFailed mMetrics 1-    InboxHandlerFailed _ attempts -> do-        recordInboxFailed mMetrics 1-        case attemptCeiling of-            Just attemptLimit | attempts >= attemptLimit -> recordInboxPoisoned mMetrics 1-            _ -> pure ()-    InboxInProgress -> pure ()+  InboxProcessed _ -> recordInboxProcessed mMetrics 1+  InboxDuplicate -> recordInboxDuplicates mMetrics 1+  InboxPreviouslyFailed _ -> recordInboxFailed mMetrics 1+  InboxHandlerFailed _ attempts -> do+    recordInboxFailed mMetrics 1+    case attemptCeiling of+      Just attemptLimit | attempts >= attemptLimit -> recordInboxPoisoned mMetrics 1+      _ -> pure ()+  InboxInProgress -> pure ()  planInboxBatch ::-    InboxDedupePolicy ->-    [(IntegrationEvent, Maybe KafkaDeliveryRef)] ->-    [BatchPlan]+  InboxDedupePolicy ->+  [(IntegrationEvent, Maybe KafkaDeliveryRef)] ->+  [BatchPlan] planInboxBatch policy = go Map.empty   where     go _ [] = []     go seen ((event, kafka) : rest) =-        case dedupeKeyFor policy event kafka of-            Left err -> BatchKeyError err : go seen rest-            Right dedupe ->-                let key = (event ^. #source, dedupe)-                 in if Map.member key seen-                        then BatchDuplicate : go seen rest-                        else BatchWork (event ^. #source) dedupe event kafka : go (Map.insert key () seen) rest--{- | Count the inbox backlog and record the gauge when metrics are enabled.+      case dedupeKeyFor policy event kafka of+        Left err -> BatchKeyError err : go seen rest+        Right dedupe ->+          let key = (event ^. #source, dedupe)+           in if Map.member key seen+                then BatchDuplicate : go seen rest+                else BatchWork (event ^. #source) dedupe event kafka : go (Map.insert key () seen) rest -The backlog is non-terminal rows: legacy @processing@ rows plus failed rows.-Schedule this on its own interval; it is intentionally not part of the-per-message intake path.--}+-- | Count the inbox backlog and record the gauge when metrics are enabled.+--+-- The backlog is non-terminal rows: legacy @processing@ rows plus failed rows.+-- Schedule this on its own interval; it is intentionally not part of the+-- per-message intake path. sampleInboxBacklog :: (IOE :> es, Store :> es) => Maybe KeiroMetrics -> Eff es () sampleInboxBacklog Nothing = pure () sampleInboxBacklog (Just metrics) = do-    backlog <- countInboxBacklog-    recordInboxBacklog (Just metrics) (fromIntegral backlog)+  backlog <- countInboxBacklog+  recordInboxBacklog (Just metrics) (fromIntegral backlog)
src/Keiro/Inbox/Kafka.hs view
@@ -1,21 +1,20 @@-{- | Reconstruct an 'IntegrationEvent' from Kafka payload bytes plus-headers.--This module is the receiving-side counterpart of-'Keiro.Outbox.Kafka.integrationEventToKafkaRecord'. It is pure: the-caller supplies the bytes and the @Text@-keyed header map produced by-its Kafka adapter, and gets back a decoded envelope or a typed error.--@keiro@ itself does not depend on @hw-kafka-client@ or-@shibuya-kafka-adapter@; the consumer adapter in EP-22 bridges the-broker library's header type to @[(Text, Text)]@ before calling-'integrationEventFromKafka'.--}-module Keiro.Inbox.Kafka (-    KafkaInboundRecord (..),+-- | Reconstruct an 'IntegrationEvent' from Kafka payload bytes plus+-- headers.+--+-- This module is the receiving-side counterpart of+-- 'Keiro.Outbox.Kafka.integrationEventToKafkaRecord'. It is pure: the+-- caller supplies the bytes and the @Text@-keyed header map produced by+-- its Kafka adapter, and gets back a decoded envelope or a typed error.+--+-- @keiro@ itself does not depend on @hw-kafka-client@ or+-- @shibuya-kafka-adapter@; the consumer adapter in EP-22 bridges the+-- broker library's header type to @[(Text, Text)]@ before calling+-- 'integrationEventFromKafka'.+module Keiro.Inbox.Kafka+  ( KafkaInboundRecord (..),     KafkaDecodeError (..),     integrationEventFromKafka,-)+  ) where  import Data.Aeson qualified as Aeson@@ -27,8 +26,8 @@ import Data.Time.Format.ISO8601 (iso8601ParseM) import Data.UUID qualified as UUID import Keiro.Inbox.Types (KafkaDeliveryRef (..))-import Keiro.Integration.Event (-    IntegrationContentType (..),+import Keiro.Integration.Event+  ( IntegrationContentType (..),     IntegrationEvent (..),     SchemaReference (..),     TraceContext (..),@@ -52,93 +51,91 @@     headerTraceParent,     headerTraceState,     parseContentType,- )+  ) import Keiro.Prelude import Kiroku.Store.Types (EventId (..), GlobalPosition (..)) -{- | A Kafka record as seen by the consumer-side adapter, decoupled from-the broker library's record type.--}+-- | A Kafka record as seen by the consumer-side adapter, decoupled from+-- the broker library's record type. data KafkaInboundRecord = KafkaInboundRecord-    { topic :: !Text-    , partition :: !Int64-    , offset :: !Int64-    , key :: !(Maybe Text)-    , payload :: !ByteString-    , headers :: ![(Text, Text)]-    , receivedAt :: !UTCTime-    }-    deriving stock (Generic, Eq, Show)+  { topic :: !Text,+    partition :: !Int64,+    offset :: !Int64,+    key :: !(Maybe Text),+    payload :: !ByteString,+    headers :: ![(Text, Text)],+    receivedAt :: !UTCTime+  }+  deriving stock (Generic, Eq, Show)  -- | Typed failures from 'integrationEventFromKafka'. data KafkaDecodeError-    = MissingHeader !Text-    | InvalidIntHeader !Text !Text-    | InvalidUuidHeader !Text !Text-    | InvalidTimeHeader !Text !Text-    | InvalidJsonHeader !Text !Text-    deriving stock (Generic, Eq, Show)--{- | Reconstruct a full 'IntegrationEvent' plus the 'KafkaDeliveryRef'-recorded for diagnostics.+  = MissingHeader !Text+  | InvalidIntHeader !Text !Text+  | InvalidUuidHeader !Text !Text+  | InvalidTimeHeader !Text !Text+  | InvalidJsonHeader !Text !Text+  deriving stock (Generic, Eq, Show) -The reconstruction is faithful to the canonical header names defined-by 'Keiro.Integration.Event' (e.g. @keiro-message-id@, @keiro-source@,-@traceparent@). Missing required headers (@keiro-source@,-@keiro-destination@, @keiro-event-type@, @keiro-schema-version@,-@content-type@, @keiro-message-id@) produce 'MissingHeader'; malformed-numeric or UUID headers produce 'InvalidIntHeader' / 'InvalidUuidHeader'.-Optional headers are silently absent in the resulting envelope.--}+-- | Reconstruct a full 'IntegrationEvent' plus the 'KafkaDeliveryRef'+-- recorded for diagnostics.+--+-- The reconstruction is faithful to the canonical header names defined+-- by 'Keiro.Integration.Event' (e.g. @keiro-message-id@, @keiro-source@,+-- @traceparent@). Missing required headers (@keiro-source@,+-- @keiro-destination@, @keiro-event-type@, @keiro-schema-version@,+-- @content-type@, @keiro-message-id@) produce 'MissingHeader'; malformed+-- numeric or UUID headers produce 'InvalidIntHeader' / 'InvalidUuidHeader'.+-- Optional headers are silently absent in the resulting envelope. integrationEventFromKafka ::-    KafkaInboundRecord ->-    Either KafkaDecodeError (IntegrationEvent, KafkaDeliveryRef)+  KafkaInboundRecord ->+  Either KafkaDecodeError (IntegrationEvent, KafkaDeliveryRef) integrationEventFromKafka record = do-    let hs = record ^. #headers-    source <- requireHeader hs headerSource-    destination <- requireHeader hs headerDestination-    eventType <- requireHeader hs headerEventType-    schemaVersionText <- requireHeader hs headerSchemaVersion-    schemaVersion <- parseInt headerSchemaVersion schemaVersionText-    contentTypeRaw <- requireHeader hs headerContentType-    messageId <- requireHeader hs headerMessageId-    schemaReference <- buildSchemaReference hs-    sourceEventId <- traverseLookup hs headerSourceEventId (fmap EventId . parseUuid headerSourceEventId)-    sourceGlobalPosition <--        traverseLookup hs headerSourceGlobalPosition (fmap GlobalPosition . parseInt headerSourceGlobalPosition)-    causationId <- traverseLookup hs headerCausationId (fmap EventId . parseUuid headerCausationId)-    correlationId <- traverseLookup hs headerCorrelationId (fmap EventId . parseUuid headerCorrelationId)-    occurredAt <- fromMaybe (record ^. #receivedAt) <$> traverseLookup hs headerOccurredAt (parseTimeHeader headerOccurredAt)-    attributes <- traverseLookup hs headerAttributes (parseJsonHeader headerAttributes)-    let traceContext = case Prelude.lookup headerTraceParent hs of-            Nothing -> Nothing-            Just tp -> Just (TraceContext tp (Prelude.lookup headerTraceState hs))-        event =-            IntegrationEvent-                { messageId-                , source-                , destination-                , key = record ^. #key-                , eventType-                , schemaVersion-                , contentType = parseContentType contentTypeRaw-                , schemaReference-                , sourceEventId-                , sourceGlobalPosition-                , payloadBytes = record ^. #payload-                , occurredAt-                , causationId-                , correlationId-                , traceContext-                , attributes-                }-        kafka =-            KafkaDeliveryRef-                { topic = record ^. #topic-                , partition = record ^. #partition-                , offset = record ^. #offset-                }-    pure (event, kafka)+  let hs = record ^. #headers+  source <- requireHeader hs headerSource+  destination <- requireHeader hs headerDestination+  eventType <- requireHeader hs headerEventType+  schemaVersionText <- requireHeader hs headerSchemaVersion+  schemaVersion <- parseInt headerSchemaVersion schemaVersionText+  contentTypeRaw <- requireHeader hs headerContentType+  messageId <- requireHeader hs headerMessageId+  schemaReference <- buildSchemaReference hs+  sourceEventId <- traverseLookup hs headerSourceEventId (fmap EventId . parseUuid headerSourceEventId)+  sourceGlobalPosition <-+    traverseLookup hs headerSourceGlobalPosition (fmap GlobalPosition . parseInt headerSourceGlobalPosition)+  causationId <- traverseLookup hs headerCausationId (fmap EventId . parseUuid headerCausationId)+  correlationId <- traverseLookup hs headerCorrelationId (fmap EventId . parseUuid headerCorrelationId)+  occurredAt <- fromMaybe (record ^. #receivedAt) <$> traverseLookup hs headerOccurredAt (parseTimeHeader headerOccurredAt)+  attributes <- traverseLookup hs headerAttributes (parseJsonHeader headerAttributes)+  let traceContext = case Prelude.lookup headerTraceParent hs of+        Nothing -> Nothing+        Just tp -> Just (TraceContext tp (Prelude.lookup headerTraceState hs))+      event =+        IntegrationEvent+          { messageId,+            source,+            destination,+            key = record ^. #key,+            eventType,+            schemaVersion,+            contentType = parseContentType contentTypeRaw,+            schemaReference,+            sourceEventId,+            sourceGlobalPosition,+            payloadBytes = record ^. #payload,+            occurredAt,+            causationId,+            correlationId,+            traceContext,+            attributes+          }+      kafka =+        KafkaDeliveryRef+          { topic = record ^. #topic,+            partition = record ^. #partition,+            offset = record ^. #offset+          }+  pure (event, kafka)  -- --------------------------------------------------------------------------- -- Helpers@@ -146,67 +143,66 @@  requireHeader :: [(Text, Text)] -> Text -> Either KafkaDecodeError Text requireHeader hs name = case Prelude.lookup name hs of-    Just v -> Right v-    Nothing -> Left (MissingHeader name)+  Just v -> Right v+  Nothing -> Left (MissingHeader name)  traverseLookup ::-    [(Text, Text)] ->-    Text ->-    (Text -> Either KafkaDecodeError a) ->-    Either KafkaDecodeError (Maybe a)+  [(Text, Text)] ->+  Text ->+  (Text -> Either KafkaDecodeError a) ->+  Either KafkaDecodeError (Maybe a) traverseLookup hs name parser = case Prelude.lookup name hs of-    Nothing -> Right Nothing-    Just raw -> fmap Just (parser raw)+  Nothing -> Right Nothing+  Just raw -> fmap Just (parser raw)  parseInt :: (Integral a) => Text -> Text -> Either KafkaDecodeError a parseInt name raw = case TextRead.signed TextRead.decimal raw of-    Right (n, rest) | Text.null rest -> Right n-    _ -> Left (InvalidIntHeader name raw)+  Right (n, rest) | Text.null rest -> Right n+  _ -> Left (InvalidIntHeader name raw)  parseUuid :: Text -> Text -> Either KafkaDecodeError UUID.UUID parseUuid name raw = case UUID.fromText raw of-    Just u -> Right u-    Nothing -> Left (InvalidUuidHeader name raw)+  Just u -> Right u+  Nothing -> Left (InvalidUuidHeader name raw)  parseTimeHeader :: Text -> Text -> Either KafkaDecodeError UTCTime parseTimeHeader name raw =-    maybe (Left (InvalidTimeHeader name raw)) Right (iso8601ParseM (Text.unpack raw))+  maybe (Left (InvalidTimeHeader name raw)) Right (iso8601ParseM (Text.unpack raw))  parseJsonHeader :: Text -> Text -> Either KafkaDecodeError Value parseJsonHeader name raw =-    case Aeson.eitherDecodeStrict (TextEncoding.encodeUtf8 raw) of-        Right value -> Right value-        Left _ -> Left (InvalidJsonHeader name raw)+  case Aeson.eitherDecodeStrict (TextEncoding.encodeUtf8 raw) of+    Right value -> Right value+    Left _ -> Left (InvalidJsonHeader name raw)  buildSchemaReference ::-    [(Text, Text)] ->-    Either KafkaDecodeError (Maybe SchemaReference)+  [(Text, Text)] ->+  Either KafkaDecodeError (Maybe SchemaReference) buildSchemaReference hs = do-    let registry = Prelude.lookup headerSchemaRegistry hs-        subject = Prelude.lookup headerSchemaSubject hs-        fingerprint = Prelude.lookup headerSchemaFingerprint hs-    versionRef <- traverseLookup hs headerSchemaVersionRef (parseInt headerSchemaVersionRef)-    schemaId <- traverseLookup hs headerSchemaId (parseInt headerSchemaId)-    let presentFields =-            mapMaybe id [registry, subject, fmap (Text.pack . show) versionRef, fmap (Text.pack . show) schemaId, fingerprint]-    if null presentFields-        then pure Nothing-        else-            pure-                ( Just-                    ( SchemaReference-                        { registry-                        , subject-                        , version = versionRef-                        , schemaId-                        , fingerprint-                        }-                    )-                )+  let registry = Prelude.lookup headerSchemaRegistry hs+      subject = Prelude.lookup headerSchemaSubject hs+      fingerprint = Prelude.lookup headerSchemaFingerprint hs+  versionRef <- traverseLookup hs headerSchemaVersionRef (parseInt headerSchemaVersionRef)+  schemaId <- traverseLookup hs headerSchemaId (parseInt headerSchemaId)+  let presentFields =+        mapMaybe id [registry, subject, fmap (Text.pack . show) versionRef, fmap (Text.pack . show) schemaId, fingerprint]+  if null presentFields+    then pure Nothing+    else+      pure+        ( Just+            ( SchemaReference+                { registry,+                  subject,+                  version = versionRef,+                  schemaId,+                  fingerprint+                }+            )+        ) -{- | Silence unused-import warning when 'IntegrationContentType' is-imported only via the open re-export but referenced through-'parseContentType'.--}+-- | Silence unused-import warning when 'IntegrationContentType' is+-- imported only via the open re-export but referenced through+-- 'parseContentType'. _unusedKeepContentType :: IntegrationContentType -> () _unusedKeepContentType _ = ()
src/Keiro/Inbox/Schema.hs view
@@ -1,13 +1,12 @@ {-# LANGUAGE ApplicativeDo #-} -{- | Hasql-level storage for the idempotent integration-event inbox.--This module owns the SQL surface that the inbox wrapper-('Keiro.Inbox.runInboxTransaction') and the optional Kafka decoder-('Keiro.Inbox.Kafka') consume.--}-module Keiro.Inbox.Schema (-    tryInsertCompletedTx,+-- | Hasql-level storage for the idempotent integration-event inbox.+--+-- This module owns the SQL surface that the inbox wrapper+-- ('Keiro.Inbox.runInboxTransaction') and the optional Kafka decoder+-- ('Keiro.Inbox.Kafka') consume.+module Keiro.Inbox.Schema+  ( tryInsertCompletedTx,     markCompletedTx,     markFailedTx,     recordFailedAttemptTx,@@ -15,7 +14,7 @@     listInbox,     garbageCollectCompleted,     countInboxBacklog,-)+  ) where  import Contravariant.Extras (contrazip2, contrazip3, contrazip4)@@ -29,226 +28,222 @@ import Hasql.Encoders qualified as E import Hasql.Statement (Statement, preparable) import Keiro.Inbox.Types-import Keiro.Integration.Event (-    IntegrationEvent (..),+import Keiro.Integration.Event+  ( IntegrationEvent (..),     SchemaReference (..),     TraceContext (..),     contentTypeText,     parseContentType,- )+  ) import Keiro.Prelude import Kiroku.Store.Effect (Store) import Kiroku.Store.Transaction (runTransaction) import Kiroku.Store.Types (EventId (..), GlobalPosition (..)) import "hasql-transaction" Hasql.Transaction qualified as Tx -{- | Attempt to insert a new completed row.--Returns 'Left' carrying the existing row if @(source, dedupe_key)@-already exists; returns 'Right ()' if the insert created a new row. The-caller — typically 'Keiro.Inbox.runInboxTransaction' — then either runs-the handler (new) or branches on the existing row's status (duplicate).--The row is inserted as @completed@ before the handler runs, but remains-uncommitted until the handler transaction succeeds. On handler failure the-whole transaction rolls back, so the completed row never becomes visible.--If a concurrent retention job deletes the conflicting row between the-insert attempt and the lookup, this returns 'Right ()'. The handler's effects-then commit without a replacement deduplication row, and a later redelivery-can run the handler again. This preserves at-least-once delivery but not-permanent exactly-once processing. Retention must exceed the maximum tolerated-redelivery delay, and handlers must remain idempotent.--}+-- | Attempt to insert a new completed row.+--+-- Returns 'Left' carrying the existing row if @(source, dedupe_key)@+-- already exists; returns 'Right ()' if the insert created a new row. The+-- caller — typically 'Keiro.Inbox.runInboxTransaction' — then either runs+-- the handler (new) or branches on the existing row's status (duplicate).+--+-- The row is inserted as @completed@ before the handler runs, but remains+-- uncommitted until the handler transaction succeeds. On handler failure the+-- whole transaction rolls back, so the completed row never becomes visible.+--+-- If a concurrent retention job deletes the conflicting row between the+-- insert attempt and the lookup, this returns 'Right ()'. The handler's effects+-- then commit without a replacement deduplication row, and a later redelivery+-- can run the handler again. This preserves at-least-once delivery but not+-- permanent exactly-once processing. Retention must exceed the maximum tolerated+-- redelivery delay, and handlers must remain idempotent. tryInsertCompletedTx ::-    InboxPersistence ->-    Text ->-    Text ->-    IntegrationEvent ->-    Maybe KafkaDeliveryRef ->-    UTCTime ->-    Tx.Transaction (Either InboxRow ())+  InboxPersistence ->+  Text ->+  Text ->+  IntegrationEvent ->+  Maybe KafkaDeliveryRef ->+  UTCTime ->+  Tx.Transaction (Either InboxRow ()) tryInsertCompletedTx persistence src dedupe event kafka now = do-    inserted <--        Tx.statement (toEncodedInsert persistence src dedupe event kafka now) tryInsertStmt-    if inserted-        then pure (Right ())-        else do-            existing <- Tx.statement (src, dedupe) selectByKeyStmt-            case existing of-                Just row -> pure (Left row)-                Nothing -> pure (Right ())+  inserted <-+    Tx.statement (toEncodedInsert persistence src dedupe event kafka now) tryInsertStmt+  if inserted+    then pure (Right ())+    else do+      existing <- Tx.statement (src, dedupe) selectByKeyStmt+      case existing of+        Just row -> pure (Left row)+        Nothing -> pure (Right ())  -- | Mark an inbox row completed inside the same transaction as the handler. markCompletedTx :: Text -> Text -> UTCTime -> Tx.Transaction () markCompletedTx src dedupe now =-    Tx.statement (src, dedupe, now) markCompletedStmt+  Tx.statement (src, dedupe, now) markCompletedStmt  -- | Mark an inbox row failed inside the same transaction as the handler. markFailedTx :: Text -> Text -> Text -> UTCTime -> Tx.Transaction () markFailedTx src dedupe errMsg now =-    Tx.statement (src, dedupe, errMsg, now) markFailedStmt--{- | Record one failed handler attempt for @(source, dedupe_key)@.+  Tx.statement (src, dedupe, errMsg, now) markFailedStmt -Creates a failed row when the handler transaction rolled back the initial-processing insert, or increments the existing failed row's attempt count.-Returns the new attempt count.--}+-- | Record one failed handler attempt for @(source, dedupe_key)@.+--+-- Creates a failed row when the handler transaction rolled back the initial+-- processing insert, or increments the existing failed row's attempt count.+-- Returns the new attempt count. recordFailedAttemptTx ::-    Text ->-    Text ->-    IntegrationEvent ->-    Maybe KafkaDeliveryRef ->-    Text ->-    UTCTime ->-    Tx.Transaction Int+  Text ->+  Text ->+  IntegrationEvent ->+  Maybe KafkaDeliveryRef ->+  Text ->+  UTCTime ->+  Tx.Transaction Int recordFailedAttemptTx src dedupe event kafka errMsg now =-    Tx.statement (toEncodedFailedInsert src dedupe event kafka errMsg now) recordFailedAttemptStmt+  Tx.statement (toEncodedFailedInsert src dedupe event kafka errMsg now) recordFailedAttemptStmt  -- | Read one inbox row. lookupInbox :: (Store :> es) => Text -> Text -> Eff es (Maybe InboxRow) lookupInbox src dedupe =-    runTransaction $-        Tx.statement (src, dedupe) selectByKeyStmt+  runTransaction $+    Tx.statement (src, dedupe) selectByKeyStmt  -- | List inbox rows for a source, ordered by @received_at@. Test helper. listInbox :: (Store :> es) => Text -> Eff es [InboxRow] listInbox src =-    runTransaction $-        Tx.statement src listBySourceStmt--{- | Count inbox rows in a non-terminal state (backlog gauge source).+  runTransaction $+    Tx.statement src listBySourceStmt -Backlog = rows still @processing@ (in flight) or @failed@ (awaiting a-retry decision). Completed rows are terminal and excluded.--}+-- | Count inbox rows in a non-terminal state (backlog gauge source).+--+-- Backlog = rows still @processing@ (in flight) or @failed@ (awaiting a+-- retry decision). Completed rows are terminal and excluded. countInboxBacklog :: (Store :> es) => Eff es Int countInboxBacklog =-    runTransaction (Tx.statement () countInboxBacklogStmt)--{- | Delete completed inbox rows older than @keepFor@ from @now@.+  runTransaction (Tx.statement () countInboxBacklogStmt) -Returns the number of rows deleted. The retention window defines the-duplicate-detection window: a redelivery that arrives after retention-GC has run will be processed again, so the window must exceed the-maximum delivery delay tolerated by the operator. The user guide-recommends 30 days as a default. See 'tryInsertCompletedTx' for the related-concurrent-GC race and its at-least-once consequence.--}+-- | Delete completed inbox rows older than @keepFor@ from @now@.+--+-- Returns the number of rows deleted. The retention window defines the+-- duplicate-detection window: a redelivery that arrives after retention+-- GC has run will be processed again, so the window must exceed the+-- maximum delivery delay tolerated by the operator. The user guide+-- recommends 30 days as a default. See 'tryInsertCompletedTx' for the related+-- concurrent-GC race and its at-least-once consequence. garbageCollectCompleted ::-    (Store :> es) =>-    NominalDiffTime ->-    UTCTime ->-    Eff es Int+  (Store :> es) =>+  NominalDiffTime ->+  UTCTime ->+  Eff es Int garbageCollectCompleted keepFor now = do-    let cutoff = addUTCTime (negate keepFor) now-    result <--        runTransaction $-            Tx.statement cutoff gcStmt-    pure (fromIntegral result)+  let cutoff = addUTCTime (negate keepFor) now+  result <-+    runTransaction $+      Tx.statement cutoff gcStmt+  pure (fromIntegral result)  -- --------------------------------------------------------------------------- -- Encoder support -- ---------------------------------------------------------------------------  data EncodedInsert = EncodedInsert-    { source :: !Text-    , dedupeKey :: !Text-    , messageId :: !(Maybe Text)-    , sourceEventId :: !(Maybe UUID)-    , sourceGlobalPosition :: !(Maybe Int64)-    , destination :: !(Maybe Text)-    , eventType :: !(Maybe Text)-    , schemaVersion :: !(Maybe Int64)-    , contentType :: !Text-    , schemaRegistry :: !(Maybe Text)-    , schemaSubject :: !(Maybe Text)-    , schemaVersionRef :: !(Maybe Int64)-    , schemaId :: !(Maybe Int64)-    , schemaFingerprint :: !(Maybe Text)-    , causationId :: !(Maybe UUID)-    , correlationId :: !(Maybe UUID)-    , traceparent :: !(Maybe Text)-    , tracestate :: !(Maybe Text)-    , kafkaTopic :: !(Maybe Text)-    , kafkaPartition :: !(Maybe Int64)-    , kafkaOffset :: !(Maybe Int64)-    , payloadBytes :: !ByteString-    , attributes :: !(Maybe Value)-    , occurredAt :: !(Maybe UTCTime)-    , receivedAt :: !UTCTime-    }-    deriving stock (Generic)+  { source :: !Text,+    dedupeKey :: !Text,+    messageId :: !(Maybe Text),+    sourceEventId :: !(Maybe UUID),+    sourceGlobalPosition :: !(Maybe Int64),+    destination :: !(Maybe Text),+    eventType :: !(Maybe Text),+    schemaVersion :: !(Maybe Int64),+    contentType :: !Text,+    schemaRegistry :: !(Maybe Text),+    schemaSubject :: !(Maybe Text),+    schemaVersionRef :: !(Maybe Int64),+    schemaId :: !(Maybe Int64),+    schemaFingerprint :: !(Maybe Text),+    causationId :: !(Maybe UUID),+    correlationId :: !(Maybe UUID),+    traceparent :: !(Maybe Text),+    tracestate :: !(Maybe Text),+    kafkaTopic :: !(Maybe Text),+    kafkaPartition :: !(Maybe Int64),+    kafkaOffset :: !(Maybe Int64),+    payloadBytes :: !ByteString,+    attributes :: !(Maybe Value),+    occurredAt :: !(Maybe UTCTime),+    receivedAt :: !UTCTime+  }+  deriving stock (Generic)  data EncodedFailedInsert = EncodedFailedInsert-    { insert :: !EncodedInsert-    , lastError :: !Text-    }-    deriving stock (Generic)+  { insert :: !EncodedInsert,+    lastError :: !Text+  }+  deriving stock (Generic)  toEncodedInsert ::-    InboxPersistence ->-    Text ->-    Text ->-    IntegrationEvent ->-    Maybe KafkaDeliveryRef ->-    UTCTime ->-    EncodedInsert+  InboxPersistence ->+  Text ->+  Text ->+  IntegrationEvent ->+  Maybe KafkaDeliveryRef ->+  UTCTime ->+  EncodedInsert toEncodedInsert persistence src dedupe event kafka now =-    let mref = event ^. #schemaReference-        mtrace = event ^. #traceContext-     in EncodedInsert-            { source = src-            , dedupeKey = dedupe-            , messageId = nullIfEmpty (event ^. #messageId)-            , sourceEventId = fmap unEventId (event ^. #sourceEventId)-            , sourceGlobalPosition = fmap unGlobalPosition (event ^. #sourceGlobalPosition)-            , destination = nullIfEmpty (event ^. #destination)-            , eventType = nullIfEmpty (event ^. #eventType)-            , schemaVersion = persistedSchema (Just (fromIntegral (event ^. #schemaVersion)))-            , contentType = contentTypeText (event ^. #contentType)-            , schemaRegistry = persistedSchema (mref >>= (^. #registry))-            , schemaSubject = persistedSchema (mref >>= (^. #subject))-            , schemaVersionRef = persistedSchema (fmap fromIntegral (mref >>= (^. #version)))-            , schemaId = persistedSchema (mref >>= (^. #schemaId))-            , schemaFingerprint = persistedSchema (mref >>= (^. #fingerprint))-            , causationId = fmap unEventId (event ^. #causationId)-            , correlationId = fmap unEventId (event ^. #correlationId)-            , traceparent = persistedEnvelope (fmap (^. #traceparent) mtrace)-            , tracestate = persistedEnvelope (mtrace >>= (^. #tracestate))-            , kafkaTopic = fmap (^. #topic) kafka-            , kafkaPartition = fmap (^. #partition) kafka-            , kafkaOffset = fmap (^. #offset) kafka-            , payloadBytes = case persistence of-                PersistFullEnvelope -> event ^. #payloadBytes-                PersistDedupeOnly -> mempty-            , attributes = persistedEnvelope (event ^. #attributes)-            , occurredAt = Just (event ^. #occurredAt)-            , receivedAt = now-            }+  let mref = event ^. #schemaReference+      mtrace = event ^. #traceContext+   in EncodedInsert+        { source = src,+          dedupeKey = dedupe,+          messageId = nullIfEmpty (event ^. #messageId),+          sourceEventId = fmap unEventId (event ^. #sourceEventId),+          sourceGlobalPosition = fmap unGlobalPosition (event ^. #sourceGlobalPosition),+          destination = nullIfEmpty (event ^. #destination),+          eventType = nullIfEmpty (event ^. #eventType),+          schemaVersion = persistedSchema (Just (fromIntegral (event ^. #schemaVersion))),+          contentType = contentTypeText (event ^. #contentType),+          schemaRegistry = persistedSchema (mref >>= (^. #registry)),+          schemaSubject = persistedSchema (mref >>= (^. #subject)),+          schemaVersionRef = persistedSchema (fmap fromIntegral (mref >>= (^. #version))),+          schemaId = persistedSchema (mref >>= (^. #schemaId)),+          schemaFingerprint = persistedSchema (mref >>= (^. #fingerprint)),+          causationId = fmap unEventId (event ^. #causationId),+          correlationId = fmap unEventId (event ^. #correlationId),+          traceparent = persistedEnvelope (fmap (^. #traceparent) mtrace),+          tracestate = persistedEnvelope (mtrace >>= (^. #tracestate)),+          kafkaTopic = fmap (^. #topic) kafka,+          kafkaPartition = fmap (^. #partition) kafka,+          kafkaOffset = fmap (^. #offset) kafka,+          payloadBytes = case persistence of+            PersistFullEnvelope -> event ^. #payloadBytes+            PersistDedupeOnly -> mempty,+          attributes = persistedEnvelope (event ^. #attributes),+          occurredAt = Just (event ^. #occurredAt),+          receivedAt = now+        }   where     persistedEnvelope :: Maybe x -> Maybe x     persistedEnvelope value = case persistence of-        PersistFullEnvelope -> value-        PersistDedupeOnly -> Nothing+      PersistFullEnvelope -> value+      PersistDedupeOnly -> Nothing      persistedSchema :: Maybe x -> Maybe x     persistedSchema = persistedEnvelope  toEncodedFailedInsert ::-    Text ->-    Text ->-    IntegrationEvent ->-    Maybe KafkaDeliveryRef ->-    Text ->-    UTCTime ->-    EncodedFailedInsert+  Text ->+  Text ->+  IntegrationEvent ->+  Maybe KafkaDeliveryRef ->+  Text ->+  UTCTime ->+  EncodedFailedInsert toEncodedFailedInsert src dedupe event kafka errMsg now =-    EncodedFailedInsert-        { insert = toEncodedInsert PersistFullEnvelope src dedupe event kafka now-        , lastError = errMsg-        }+  EncodedFailedInsert+    { insert = toEncodedInsert PersistFullEnvelope src dedupe event kafka now,+      lastError = errMsg+    }  nullIfEmpty :: Text -> Maybe Text nullIfEmpty t = if t == mempty then Nothing else Just t@@ -261,38 +256,38 @@  encodedInsertEncoder :: E.Params EncodedInsert encodedInsertEncoder =-    mconcat-        [ view #source >$< E.param (E.nonNullable E.text)-        , view #dedupeKey >$< E.param (E.nonNullable E.text)-        , view #messageId >$< E.param (E.nullable E.text)-        , view #sourceEventId >$< E.param (E.nullable E.uuid)-        , view #sourceGlobalPosition >$< E.param (E.nullable E.int8)-        , view #destination >$< E.param (E.nullable E.text)-        , view #eventType >$< E.param (E.nullable E.text)-        , view #schemaVersion >$< E.param (E.nullable E.int8)-        , view #contentType >$< E.param (E.nonNullable E.text)-        , view #schemaRegistry >$< E.param (E.nullable E.text)-        , view #schemaSubject >$< E.param (E.nullable E.text)-        , view #schemaVersionRef >$< E.param (E.nullable E.int8)-        , view #schemaId >$< E.param (E.nullable E.int8)-        , view #schemaFingerprint >$< E.param (E.nullable E.text)-        , view #causationId >$< E.param (E.nullable E.uuid)-        , view #correlationId >$< E.param (E.nullable E.uuid)-        , view #traceparent >$< E.param (E.nullable E.text)-        , view #tracestate >$< E.param (E.nullable E.text)-        , view #kafkaTopic >$< E.param (E.nullable E.text)-        , view #kafkaPartition >$< E.param (E.nullable E.int8)-        , view #kafkaOffset >$< E.param (E.nullable E.int8)-        , view #payloadBytes >$< E.param (E.nonNullable E.bytea)-        , view #attributes >$< E.param (E.nullable E.jsonb)-        , view #occurredAt >$< E.param (E.nullable E.timestamptz)-        , view #receivedAt >$< E.param (E.nonNullable E.timestamptz)-        ]+  mconcat+    [ view #source >$< E.param (E.nonNullable E.text),+      view #dedupeKey >$< E.param (E.nonNullable E.text),+      view #messageId >$< E.param (E.nullable E.text),+      view #sourceEventId >$< E.param (E.nullable E.uuid),+      view #sourceGlobalPosition >$< E.param (E.nullable E.int8),+      view #destination >$< E.param (E.nullable E.text),+      view #eventType >$< E.param (E.nullable E.text),+      view #schemaVersion >$< E.param (E.nullable E.int8),+      view #contentType >$< E.param (E.nonNullable E.text),+      view #schemaRegistry >$< E.param (E.nullable E.text),+      view #schemaSubject >$< E.param (E.nullable E.text),+      view #schemaVersionRef >$< E.param (E.nullable E.int8),+      view #schemaId >$< E.param (E.nullable E.int8),+      view #schemaFingerprint >$< E.param (E.nullable E.text),+      view #causationId >$< E.param (E.nullable E.uuid),+      view #correlationId >$< E.param (E.nullable E.uuid),+      view #traceparent >$< E.param (E.nullable E.text),+      view #tracestate >$< E.param (E.nullable E.text),+      view #kafkaTopic >$< E.param (E.nullable E.text),+      view #kafkaPartition >$< E.param (E.nullable E.int8),+      view #kafkaOffset >$< E.param (E.nullable E.int8),+      view #payloadBytes >$< E.param (E.nonNullable E.bytea),+      view #attributes >$< E.param (E.nullable E.jsonb),+      view #occurredAt >$< E.param (E.nullable E.timestamptz),+      view #receivedAt >$< E.param (E.nonNullable E.timestamptz)+    ]  encodedFailedInsertEncoder :: E.Params EncodedFailedInsert encodedFailedInsertEncoder =-    (view #insert >$< encodedInsertEncoder)-        <> (view #lastError >$< E.param (E.nonNullable E.text))+  (view #insert >$< encodedInsertEncoder)+    <> (view #lastError >$< E.param (E.nonNullable E.text))  -- --------------------------------------------------------------------------- -- Statements@@ -300,314 +295,313 @@  tryInsertStmt :: Statement EncodedInsert Bool tryInsertStmt =-    preparable-        """-        INSERT INTO keiro.keiro_inbox-          ( source-          , dedupe_key-          , message_id-          , source_event_id-          , source_global_position-          , destination-          , event_type-          , schema_version-          , content_type-          , schema_registry-          , schema_subject-          , schema_version_ref-          , schema_id-          , schema_fingerprint-          , causation_id-          , correlation_id-          , traceparent-          , tracestate-          , kafka_topic-          , kafka_partition-          , kafka_offset-          , payload_bytes-          , attributes-          , occurred_at-          , received_at-          , status-          , completed_at-          )-        VALUES-          ($1, $2, $3, $4, $5, $6, $7, $8, $9, $10, $11, $12, $13, $14, $15, $16, $17, $18, $19, $20, $21, $22, $23, $24, $25, 'completed', $25)-        ON CONFLICT (source, dedupe_key) DO NOTHING-        RETURNING TRUE-        """-        encodedInsertEncoder-        (fmap (fromMaybe False) (D.rowMaybe (D.column (D.nonNullable D.bool))))+  preparable+    """+    INSERT INTO keiro.keiro_inbox+      ( source+      , dedupe_key+      , message_id+      , source_event_id+      , source_global_position+      , destination+      , event_type+      , schema_version+      , content_type+      , schema_registry+      , schema_subject+      , schema_version_ref+      , schema_id+      , schema_fingerprint+      , causation_id+      , correlation_id+      , traceparent+      , tracestate+      , kafka_topic+      , kafka_partition+      , kafka_offset+      , payload_bytes+      , attributes+      , occurred_at+      , received_at+      , status+      , completed_at+      )+    VALUES+      ($1, $2, $3, $4, $5, $6, $7, $8, $9, $10, $11, $12, $13, $14, $15, $16, $17, $18, $19, $20, $21, $22, $23, $24, $25, 'completed', $25)+    ON CONFLICT (source, dedupe_key) DO NOTHING+    RETURNING TRUE+    """+    encodedInsertEncoder+    (fmap (fromMaybe False) (D.rowMaybe (D.column (D.nonNullable D.bool))))  markCompletedStmt :: Statement (Text, Text, UTCTime) () markCompletedStmt =-    preparable-        """-        UPDATE keiro.keiro_inbox-        SET status = 'completed',-            completed_at = $3,-            last_error = NULL-        WHERE source = $1 AND dedupe_key = $2-        """-        ( contrazip3-            (E.param (E.nonNullable E.text))-            (E.param (E.nonNullable E.text))-            (E.param (E.nonNullable E.timestamptz))-        )-        D.noResult+  preparable+    """+    UPDATE keiro.keiro_inbox+    SET status = 'completed',+        completed_at = $3,+        last_error = NULL+    WHERE source = $1 AND dedupe_key = $2+    """+    ( contrazip3+        (E.param (E.nonNullable E.text))+        (E.param (E.nonNullable E.text))+        (E.param (E.nonNullable E.timestamptz))+    )+    D.noResult  markFailedStmt :: Statement (Text, Text, Text, UTCTime) () markFailedStmt =-    preparable-        """-        UPDATE keiro.keiro_inbox-        SET status = 'failed',-            failed_at = $4,-            last_error = $3-        WHERE source = $1 AND dedupe_key = $2-        """-        ( contrazip4-            (E.param (E.nonNullable E.text))-            (E.param (E.nonNullable E.text))-            (E.param (E.nonNullable E.text))-            (E.param (E.nonNullable E.timestamptz))-        )-        D.noResult+  preparable+    """+    UPDATE keiro.keiro_inbox+    SET status = 'failed',+        failed_at = $4,+        last_error = $3+    WHERE source = $1 AND dedupe_key = $2+    """+    ( contrazip4+        (E.param (E.nonNullable E.text))+        (E.param (E.nonNullable E.text))+        (E.param (E.nonNullable E.text))+        (E.param (E.nonNullable E.timestamptz))+    )+    D.noResult  recordFailedAttemptStmt :: Statement EncodedFailedInsert Int recordFailedAttemptStmt =-    preparable-        """-        INSERT INTO keiro.keiro_inbox-          ( source-          , dedupe_key-          , message_id-          , source_event_id-          , source_global_position-          , destination-          , event_type-          , schema_version-          , content_type-          , schema_registry-          , schema_subject-          , schema_version_ref-          , schema_id-          , schema_fingerprint-          , causation_id-          , correlation_id-          , traceparent-          , tracestate-          , kafka_topic-          , kafka_partition-          , kafka_offset-          , payload_bytes-          , attributes-          , occurred_at-          , received_at-          , status-          , attempt_count-          , failed_at-          , last_error-          )-        VALUES-          ($1, $2, $3, $4, $5, $6, $7, $8, $9, $10, $11, $12, $13, $14, $15, $16, $17, $18, $19, $20, $21, $22, $23, $24, $25, 'failed', 1, $25, $26)-        ON CONFLICT (source, dedupe_key) DO UPDATE-        SET status = 'failed',-            attempt_count = keiro_inbox.attempt_count + 1,-            last_error = EXCLUDED.last_error,-            failed_at = EXCLUDED.failed_at-        RETURNING attempt_count-        """-        encodedFailedInsertEncoder-        (fmap fromIntegral (D.singleRow (D.column (D.nonNullable D.int8))))+  preparable+    """+    INSERT INTO keiro.keiro_inbox+      ( source+      , dedupe_key+      , message_id+      , source_event_id+      , source_global_position+      , destination+      , event_type+      , schema_version+      , content_type+      , schema_registry+      , schema_subject+      , schema_version_ref+      , schema_id+      , schema_fingerprint+      , causation_id+      , correlation_id+      , traceparent+      , tracestate+      , kafka_topic+      , kafka_partition+      , kafka_offset+      , payload_bytes+      , attributes+      , occurred_at+      , received_at+      , status+      , attempt_count+      , failed_at+      , last_error+      )+    VALUES+      ($1, $2, $3, $4, $5, $6, $7, $8, $9, $10, $11, $12, $13, $14, $15, $16, $17, $18, $19, $20, $21, $22, $23, $24, $25, 'failed', 1, $25, $26)+    ON CONFLICT (source, dedupe_key) DO UPDATE+    SET status = 'failed',+        attempt_count = keiro_inbox.attempt_count + 1,+        last_error = EXCLUDED.last_error,+        failed_at = EXCLUDED.failed_at+    RETURNING attempt_count+    """+    encodedFailedInsertEncoder+    (fmap fromIntegral (D.singleRow (D.column (D.nonNullable D.int8))))  selectByKeyStmt :: Statement (Text, Text) (Maybe InboxRow) selectByKeyStmt =-    preparable-        (selectAllSql <> " WHERE source = $1 AND dedupe_key = $2")-        ( contrazip2-            (E.param (E.nonNullable E.text))-            (E.param (E.nonNullable E.text))-        )-        (D.rowMaybe inboxRowDecoder)+  preparable+    (selectAllSql <> " WHERE source = $1 AND dedupe_key = $2")+    ( contrazip2+        (E.param (E.nonNullable E.text))+        (E.param (E.nonNullable E.text))+    )+    (D.rowMaybe inboxRowDecoder)  listBySourceStmt :: Statement Text [InboxRow] listBySourceStmt =-    preparable-        (selectAllSql <> " WHERE source = $1 ORDER BY received_at, dedupe_key")-        (E.param (E.nonNullable E.text))-        (D.rowList inboxRowDecoder)+  preparable+    (selectAllSql <> " WHERE source = $1 ORDER BY received_at, dedupe_key")+    (E.param (E.nonNullable E.text))+    (D.rowList inboxRowDecoder)  countInboxBacklogStmt :: Statement () Int countInboxBacklogStmt =-    preparable-        "SELECT COUNT(*)::bigint FROM keiro.keiro_inbox WHERE status IN ('processing', 'failed')"-        E.noParams-        (fmap fromIntegral (D.singleRow (D.column (D.nonNullable D.int8))))+  preparable+    "SELECT COUNT(*)::bigint FROM keiro.keiro_inbox WHERE status IN ('processing', 'failed')"+    E.noParams+    (fmap fromIntegral (D.singleRow (D.column (D.nonNullable D.int8))))  gcStmt :: Statement UTCTime Int64 gcStmt =-    preparable-        """-        WITH deleted AS (-          DELETE FROM keiro.keiro_inbox-          WHERE status = 'completed' AND completed_at < $1-          RETURNING 1-        )-        SELECT COALESCE(COUNT(*), 0)::bigint FROM deleted-        """-        (E.param (E.nonNullable E.timestamptz))-        (D.singleRow (D.column (D.nonNullable D.int8)))+  preparable+    """+    WITH deleted AS (+      DELETE FROM keiro.keiro_inbox+      WHERE status = 'completed' AND completed_at < $1+      RETURNING 1+    )+    SELECT COALESCE(COUNT(*), 0)::bigint FROM deleted+    """+    (E.param (E.nonNullable E.timestamptz))+    (D.singleRow (D.column (D.nonNullable D.int8)))  selectAllSql :: Text selectAllSql =-    """-    SELECT source, dedupe_key, message_id, source_event_id, source_global_position,-           destination, event_type, schema_version, content_type, schema_registry,-           schema_subject, schema_version_ref, schema_id, schema_fingerprint,-           causation_id, correlation_id, traceparent, tracestate, kafka_topic,-           kafka_partition, kafka_offset, payload_bytes, attributes, occurred_at,-           status, attempt_count, received_at, completed_at, failed_at, last_error-    FROM keiro.keiro_inbox-    """+  """+  SELECT source, dedupe_key, message_id, source_event_id, source_global_position,+         destination, event_type, schema_version, content_type, schema_registry,+         schema_subject, schema_version_ref, schema_id, schema_fingerprint,+         causation_id, correlation_id, traceparent, tracestate, kafka_topic,+         kafka_partition, kafka_offset, payload_bytes, attributes, occurred_at,+         status, attempt_count, received_at, completed_at, failed_at, last_error+  FROM keiro.keiro_inbox+  """  inboxRowDecoder :: D.Row InboxRow inboxRowDecoder = fmap assembleInboxRow rawDecoder  data RawInbox = RawInbox-    { source :: !Text-    , dedupeKey :: !Text-    , messageId :: !(Maybe Text)-    , sourceEventId :: !(Maybe EventId)-    , sourceGlobalPosition :: !(Maybe GlobalPosition)-    , destination :: !(Maybe Text)-    , eventType :: !(Maybe Text)-    , schemaVersion :: !(Maybe Int)-    , contentType :: !Text-    , schemaRegistry :: !(Maybe Text)-    , schemaSubject :: !(Maybe Text)-    , schemaVersionRef :: !(Maybe Int)-    , schemaId :: !(Maybe Int64)-    , schemaFingerprint :: !(Maybe Text)-    , causationId :: !(Maybe EventId)-    , correlationId :: !(Maybe EventId)-    , traceparent :: !(Maybe Text)-    , tracestate :: !(Maybe Text)-    , kafkaTopic :: !(Maybe Text)-    , kafkaPartition :: !(Maybe Int64)-    , kafkaOffset :: !(Maybe Int64)-    , payloadBytes :: !ByteString-    , attributes :: !(Maybe Value)-    , occurredAt :: !(Maybe UTCTime)-    , status :: !InboxStatus-    , attemptCount :: !Int-    , receivedAt :: !UTCTime-    , completedAt :: !(Maybe UTCTime)-    , failedAt :: !(Maybe UTCTime)-    , lastError :: !(Maybe Text)-    }-    deriving stock (Generic)+  { source :: !Text,+    dedupeKey :: !Text,+    messageId :: !(Maybe Text),+    sourceEventId :: !(Maybe EventId),+    sourceGlobalPosition :: !(Maybe GlobalPosition),+    destination :: !(Maybe Text),+    eventType :: !(Maybe Text),+    schemaVersion :: !(Maybe Int),+    contentType :: !Text,+    schemaRegistry :: !(Maybe Text),+    schemaSubject :: !(Maybe Text),+    schemaVersionRef :: !(Maybe Int),+    schemaId :: !(Maybe Int64),+    schemaFingerprint :: !(Maybe Text),+    causationId :: !(Maybe EventId),+    correlationId :: !(Maybe EventId),+    traceparent :: !(Maybe Text),+    tracestate :: !(Maybe Text),+    kafkaTopic :: !(Maybe Text),+    kafkaPartition :: !(Maybe Int64),+    kafkaOffset :: !(Maybe Int64),+    payloadBytes :: !ByteString,+    attributes :: !(Maybe Value),+    occurredAt :: !(Maybe UTCTime),+    status :: !InboxStatus,+    attemptCount :: !Int,+    receivedAt :: !UTCTime,+    completedAt :: !(Maybe UTCTime),+    failedAt :: !(Maybe UTCTime),+    lastError :: !(Maybe Text)+  }+  deriving stock (Generic)  rawDecoder :: D.Row RawInbox rawDecoder =-    RawInbox-        <$> D.column (D.nonNullable D.text)-        <*> D.column (D.nonNullable D.text)-        <*> D.column (D.nullable D.text)-        <*> (fmap EventId <$> D.column (D.nullable D.uuid))-        <*> (fmap GlobalPosition <$> D.column (D.nullable D.int8))-        <*> D.column (D.nullable D.text)-        <*> D.column (D.nullable D.text)-        <*> (fmap fromIntegral <$> D.column (D.nullable D.int8))-        <*> D.column (D.nonNullable D.text)-        <*> D.column (D.nullable D.text)-        <*> D.column (D.nullable D.text)-        <*> (fmap fromIntegral <$> D.column (D.nullable D.int8))-        <*> D.column (D.nullable D.int8)-        <*> D.column (D.nullable D.text)-        <*> (fmap EventId <$> D.column (D.nullable D.uuid))-        <*> (fmap EventId <$> D.column (D.nullable D.uuid))-        <*> D.column (D.nullable D.text)-        <*> D.column (D.nullable D.text)-        <*> D.column (D.nullable D.text)-        <*> D.column (D.nullable D.int8)-        <*> D.column (D.nullable D.int8)-        <*> D.column (D.nonNullable D.bytea)-        <*> D.column (D.nullable D.jsonb)-        <*> D.column (D.nullable D.timestamptz)-        <*> D.column (D.nonNullable (D.refine parseInboxStatus D.text))-        <*> (fromIntegral <$> D.column (D.nonNullable D.int8))-        <*> D.column (D.nonNullable D.timestamptz)-        <*> D.column (D.nullable D.timestamptz)-        <*> D.column (D.nullable D.timestamptz)-        <*> D.column (D.nullable D.text)+  RawInbox+    <$> D.column (D.nonNullable D.text)+    <*> D.column (D.nonNullable D.text)+    <*> D.column (D.nullable D.text)+    <*> (fmap EventId <$> D.column (D.nullable D.uuid))+    <*> (fmap GlobalPosition <$> D.column (D.nullable D.int8))+    <*> D.column (D.nullable D.text)+    <*> D.column (D.nullable D.text)+    <*> (fmap fromIntegral <$> D.column (D.nullable D.int8))+    <*> D.column (D.nonNullable D.text)+    <*> D.column (D.nullable D.text)+    <*> D.column (D.nullable D.text)+    <*> (fmap fromIntegral <$> D.column (D.nullable D.int8))+    <*> D.column (D.nullable D.int8)+    <*> D.column (D.nullable D.text)+    <*> (fmap EventId <$> D.column (D.nullable D.uuid))+    <*> (fmap EventId <$> D.column (D.nullable D.uuid))+    <*> D.column (D.nullable D.text)+    <*> D.column (D.nullable D.text)+    <*> D.column (D.nullable D.text)+    <*> D.column (D.nullable D.int8)+    <*> D.column (D.nullable D.int8)+    <*> D.column (D.nonNullable D.bytea)+    <*> D.column (D.nullable D.jsonb)+    <*> D.column (D.nullable D.timestamptz)+    <*> D.column (D.nonNullable (D.refine parseInboxStatus D.text))+    <*> (fromIntegral <$> D.column (D.nonNullable D.int8))+    <*> D.column (D.nonNullable D.timestamptz)+    <*> D.column (D.nullable D.timestamptz)+    <*> D.column (D.nullable D.timestamptz)+    <*> D.column (D.nullable D.text)  assembleInboxRow :: RawInbox -> InboxRow assembleInboxRow raw =-    let traceContext = case raw ^. #traceparent of-            Nothing -> Nothing-            Just tp -> Just (TraceContext tp (raw ^. #tracestate))-        schemaReference =-            case ( raw ^. #schemaRegistry-                 , raw ^. #schemaSubject-                 , raw ^. #schemaVersionRef-                 , raw ^. #schemaId-                 , raw ^. #schemaFingerprint-                 ) of-                (Nothing, Nothing, Nothing, Nothing, Nothing) -> Nothing-                _ ->-                    Just-                        ( SchemaReference-                            (raw ^. #schemaRegistry)-                            (raw ^. #schemaSubject)-                            (raw ^. #schemaVersionRef)-                            (raw ^. #schemaId)-                            (raw ^. #schemaFingerprint)-                        )-        kafka =-            case (raw ^. #kafkaTopic, raw ^. #kafkaPartition, raw ^. #kafkaOffset) of-                (Just t, Just p, Just o) -> Just (KafkaDeliveryRef t p o)-                _ -> Nothing-        event =-            IntegrationEvent-                { messageId = fromMaybe mempty (raw ^. #messageId)-                , source = raw ^. #source-                , destination = fromMaybe mempty (raw ^. #destination)-                , key = Nothing-                , -- @key@ is not part of the inbox primary key and is not-                  -- carried separately on the row — the same partition info-                  -- lives in @kafka@. Receivers that need it can re-derive-                  -- from the payload.-                  eventType = fromMaybe mempty (raw ^. #eventType)-                , schemaVersion = fromMaybe 0 (raw ^. #schemaVersion)-                , contentType = parseContentType (raw ^. #contentType)-                , schemaReference-                , sourceEventId = raw ^. #sourceEventId-                , sourceGlobalPosition = raw ^. #sourceGlobalPosition-                , payloadBytes = raw ^. #payloadBytes-                , occurredAt = fromMaybe defaultEpoch (raw ^. #occurredAt)-                , causationId = raw ^. #causationId-                , correlationId = raw ^. #correlationId-                , traceContext-                , attributes = raw ^. #attributes-                }-     in InboxRow-            { source = raw ^. #source-            , dedupeKey = raw ^. #dedupeKey-            , event-            , kafka-            , status = raw ^. #status-            , attemptCount = raw ^. #attemptCount-            , receivedAt = raw ^. #receivedAt-            , completedAt = raw ^. #completedAt-            , failedAt = raw ^. #failedAt-            , lastError = raw ^. #lastError-            }--{- | Sentinel used when an inbox row was written without an @occurred_at@.+  let traceContext = case raw ^. #traceparent of+        Nothing -> Nothing+        Just tp -> Just (TraceContext tp (raw ^. #tracestate))+      schemaReference =+        case ( raw ^. #schemaRegistry,+               raw ^. #schemaSubject,+               raw ^. #schemaVersionRef,+               raw ^. #schemaId,+               raw ^. #schemaFingerprint+             ) of+          (Nothing, Nothing, Nothing, Nothing, Nothing) -> Nothing+          _ ->+            Just+              ( SchemaReference+                  (raw ^. #schemaRegistry)+                  (raw ^. #schemaSubject)+                  (raw ^. #schemaVersionRef)+                  (raw ^. #schemaId)+                  (raw ^. #schemaFingerprint)+              )+      kafka =+        case (raw ^. #kafkaTopic, raw ^. #kafkaPartition, raw ^. #kafkaOffset) of+          (Just t, Just p, Just o) -> Just (KafkaDeliveryRef t p o)+          _ -> Nothing+      event =+        IntegrationEvent+          { messageId = fromMaybe mempty (raw ^. #messageId),+            source = raw ^. #source,+            destination = fromMaybe mempty (raw ^. #destination),+            key = Nothing,+            -- @key@ is not part of the inbox primary key and is not+            -- carried separately on the row — the same partition info+            -- lives in @kafka@. Receivers that need it can re-derive+            -- from the payload.+            eventType = fromMaybe mempty (raw ^. #eventType),+            schemaVersion = fromMaybe 0 (raw ^. #schemaVersion),+            contentType = parseContentType (raw ^. #contentType),+            schemaReference,+            sourceEventId = raw ^. #sourceEventId,+            sourceGlobalPosition = raw ^. #sourceGlobalPosition,+            payloadBytes = raw ^. #payloadBytes,+            occurredAt = fromMaybe defaultEpoch (raw ^. #occurredAt),+            causationId = raw ^. #causationId,+            correlationId = raw ^. #correlationId,+            traceContext,+            attributes = raw ^. #attributes+          }+   in InboxRow+        { source = raw ^. #source,+          dedupeKey = raw ^. #dedupeKey,+          event,+          kafka,+          status = raw ^. #status,+          attemptCount = raw ^. #attemptCount,+          receivedAt = raw ^. #receivedAt,+          completedAt = raw ^. #completedAt,+          failedAt = raw ^. #failedAt,+          lastError = raw ^. #lastError+        } -Inbox rows are observability-shaped; consumers that care should-re-read the timestamp from the envelope payload directly.--}+-- | Sentinel used when an inbox row was written without an @occurred_at@.+--+-- Inbox rows are observability-shaped; consumers that care should+-- re-read the timestamp from the envelope payload directly. defaultEpoch :: UTCTime defaultEpoch = posixSecondsToUTCTime 0
src/Keiro/Inbox/Types.hs view
@@ -1,14 +1,13 @@-{- | Shared types for the idempotent integration-event inbox.--The inbox lives in the consuming bounded context. When a Kafka consumer-receives an integration event, the inbox records a stable external-identity for that message and runs the local handler in the same-transaction. Duplicate redeliveries (Kafka offset retry, rebalance,-producer republish) become observable as duplicates instead of-re-running the handler.--}-module Keiro.Inbox.Types (-    InboxDedupePolicy (..),+-- | Shared types for the idempotent integration-event inbox.+--+-- The inbox lives in the consuming bounded context. When a Kafka consumer+-- receives an integration event, the inbox records a stable external+-- identity for that message and runs the local handler in the same+-- transaction. Duplicate redeliveries (Kafka offset retry, rebalance,+-- producer republish) become observable as duplicates instead of+-- re-running the handler.+module Keiro.Inbox.Types+  ( InboxDedupePolicy (..),     InboxPersistence (..),     InboxStatus (..),     InboxResult (..),@@ -18,7 +17,7 @@     inboxStatusText,     parseInboxStatus,     dedupeKeyFor,-)+  ) where  import Data.Text qualified as Text@@ -27,172 +26,164 @@ import Keiro.Prelude import Kiroku.Store.Types (EventId (..), GlobalPosition (..)) -{- | Which identity is used as the inbox primary key for an-'IntegrationEvent'.--* 'PreferIntegrationMessageId' (default) — use the application-level-  @messageId@ minted at the producer's outbox enqueue. EP-19 / EP-20-  keep this id stable across publish retries, so it is the natural-  primary dedupe key for Kafka-delivered events.-* 'PreferSourceEventIdentity' — use the @sourceEventId@ of the private-  event that produced this integration event. Useful when a producer-  may emit the same logical fact under different @messageId@s (e.g.-  schema-upgrade republish), and the consumer wants those republishes-  collapsed to a single handler run.-* 'KafkaDeliveryIdentity' — use the Kafka topic-partition-offset triple-  as the dedupe key. Fallback only when neither @messageId@ nor source-  identity is available. This identifies one broker delivery, not one-  logical producer message: if a producer republishes the same logical-  message, Kafka assigns a new offset and this policy will not collapse-  the republish.-* 'CustomDedupeKey' — caller supplies the key. Use only when the other-  policies cannot represent the identity scheme; the consuming service-  owns key collision resistance.--}+-- | Which identity is used as the inbox primary key for an+-- 'IntegrationEvent'.+--+-- * 'PreferIntegrationMessageId' (default) — use the application-level+--   @messageId@ minted at the producer's outbox enqueue. EP-19 / EP-20+--   keep this id stable across publish retries, so it is the natural+--   primary dedupe key for Kafka-delivered events.+-- * 'PreferSourceEventIdentity' — use the @sourceEventId@ of the private+--   event that produced this integration event. Useful when a producer+--   may emit the same logical fact under different @messageId@s (e.g.+--   schema-upgrade republish), and the consumer wants those republishes+--   collapsed to a single handler run.+-- * 'KafkaDeliveryIdentity' — use the Kafka topic-partition-offset triple+--   as the dedupe key. Fallback only when neither @messageId@ nor source+--   identity is available. This identifies one broker delivery, not one+--   logical producer message: if a producer republishes the same logical+--   message, Kafka assigns a new offset and this policy will not collapse+--   the republish.+-- * 'CustomDedupeKey' — caller supplies the key. Use only when the other+--   policies cannot represent the identity scheme; the consuming service+--   owns key collision resistance. data InboxDedupePolicy-    = PreferIntegrationMessageId-    | PreferSourceEventIdentity-    | KafkaDeliveryIdentity-    | CustomDedupeKey !Text-    deriving stock (Generic, Eq, Show)--{- | How much of the integration-event envelope the inbox persists on the-success path.+  = PreferIntegrationMessageId+  | PreferSourceEventIdentity+  | KafkaDeliveryIdentity+  | CustomDedupeKey !Text+  deriving stock (Generic, Eq, Show) -The failure path always persists the full envelope because a failed-inbox row is the operator's dead-letter record.--}+-- | How much of the integration-event envelope the inbox persists on the+-- success path.+--+-- The failure path always persists the full envelope because a failed+-- inbox row is the operator's dead-letter record. data InboxPersistence-    = PersistFullEnvelope-    | PersistDedupeOnly-    deriving stock (Generic, Eq, Show)--{- | Lifecycle state of an inbox row.+  = PersistFullEnvelope+  | PersistDedupeOnly+  deriving stock (Generic, Eq, Show) -* 'InboxProcessing' — legacy on-disk state from older wrappers and-  reserved for future async paths. Current single-transaction intake-  inserts fresh successful rows directly as 'InboxCompleted'.-* 'InboxCompleted' — handler ran to completion; terminal.-* 'InboxFailed' — handler signaled a permanent failure; terminal. The-  caller is responsible for operator action (dead-letter, manual-  retry).--}+-- | Lifecycle state of an inbox row.+--+-- * 'InboxProcessing' — legacy on-disk state from older wrappers and+--   reserved for future async paths. Current single-transaction intake+--   inserts fresh successful rows directly as 'InboxCompleted'.+-- * 'InboxCompleted' — handler ran to completion; terminal.+-- * 'InboxFailed' — handler signaled a permanent failure; terminal. The+--   caller is responsible for operator action (dead-letter, manual+--   retry). data InboxStatus-    = InboxProcessing-    | InboxCompleted-    | InboxFailed-    deriving stock (Generic, Eq, Show)--{- | The classified outcome of 'Keiro.Inbox.runInboxTransaction'.+  = InboxProcessing+  | InboxCompleted+  | InboxFailed+  deriving stock (Generic, Eq, Show) -* 'InboxProcessed a' — first delivery; handler ran and returned @a@.-* 'InboxDuplicate' — a previous delivery already completed; handler not-  run.-* 'InboxInProgress' — a previous attempt is currently in-flight, or a-  legacy @processing@ row was read. Current single-transaction intake-  does not commit @processing@ rows. Treat as transient.-* 'InboxPreviouslyFailed' — a previous attempt recorded a permanent-  failure. Operator should review before reprocessing.--}+-- | The classified outcome of 'Keiro.Inbox.runInboxTransaction'.+--+-- * 'InboxProcessed a' — first delivery; handler ran and returned @a@.+-- * 'InboxDuplicate' — a previous delivery already completed; handler not+--   run.+-- * 'InboxInProgress' — a previous attempt is currently in-flight, or a+--   legacy @processing@ row was read. Current single-transaction intake+--   does not commit @processing@ rows. Treat as transient.+-- * 'InboxPreviouslyFailed' — a previous attempt recorded a permanent+--   failure. Operator should review before reprocessing. data InboxResult a-    = InboxProcessed !a-    | InboxDuplicate-    | InboxInProgress-    | InboxPreviouslyFailed !(Maybe Text)-    | InboxHandlerFailed !Text !Int-    deriving stock (Generic, Eq, Show)+  = InboxProcessed !a+  | InboxDuplicate+  | InboxInProgress+  | InboxPreviouslyFailed !(Maybe Text)+  | InboxHandlerFailed !Text !Int+  deriving stock (Generic, Eq, Show) -{- | Errors surfaced by the inbox wrapper that originate from the inbox-itself rather than from the supplied handler.--}+-- | Errors surfaced by the inbox wrapper that originate from the inbox+-- itself rather than from the supplied handler. data InboxError-    = -- | The integration event lacked the field required by the chosen policy.-      DedupePolicyUnsatisfied !InboxDedupePolicy-    deriving stock (Generic, Eq, Show)--{- | Optional Kafka-delivery metadata recorded alongside an inbox row.+  = -- | The integration event lacked the field required by the chosen policy.+    DedupePolicyUnsatisfied !InboxDedupePolicy+  deriving stock (Generic, Eq, Show) -Used by 'KafkaDeliveryIdentity' to compute the dedupe key, and stored on-the row regardless of policy so operators can correlate the inbox-record with Kafka logs. Not part of the EP-19 envelope.--}+-- | Optional Kafka-delivery metadata recorded alongside an inbox row.+--+-- Used by 'KafkaDeliveryIdentity' to compute the dedupe key, and stored on+-- the row regardless of policy so operators can correlate the inbox+-- record with Kafka logs. Not part of the EP-19 envelope. data KafkaDeliveryRef = KafkaDeliveryRef-    { topic :: !Text-    , partition :: !Int64-    , offset :: !Int64-    }-    deriving stock (Generic, Eq, Show)--{- | One row read back from @keiro_inbox@.+  { topic :: !Text,+    partition :: !Int64,+    offset :: !Int64+  }+  deriving stock (Generic, Eq, Show) -Rows written with 'PersistDedupeOnly' decode with an empty-'IntegrationEvent' @payloadBytes@, no attributes, no trace context, and-no schema reference. Identity, routing, source-event ids, occurrence-time, and Kafka delivery metadata are still preserved.--}+-- | One row read back from @keiro_inbox@.+--+-- Rows written with 'PersistDedupeOnly' decode with an empty+-- 'IntegrationEvent' @payloadBytes@, no attributes, no trace context, and+-- no schema reference. Identity, routing, source-event ids, occurrence+-- time, and Kafka delivery metadata are still preserved. data InboxRow = InboxRow-    { source :: !Text-    , dedupeKey :: !Text-    , event :: !IntegrationEvent-    , kafka :: !(Maybe KafkaDeliveryRef)-    , status :: !InboxStatus-    , attemptCount :: !Int-    , receivedAt :: !UTCTime-    , completedAt :: !(Maybe UTCTime)-    , failedAt :: !(Maybe UTCTime)-    , lastError :: !(Maybe Text)-    }-    deriving stock (Generic, Eq, Show)+  { source :: !Text,+    dedupeKey :: !Text,+    event :: !IntegrationEvent,+    kafka :: !(Maybe KafkaDeliveryRef),+    status :: !InboxStatus,+    attemptCount :: !Int,+    receivedAt :: !UTCTime,+    completedAt :: !(Maybe UTCTime),+    failedAt :: !(Maybe UTCTime),+    lastError :: !(Maybe Text)+  }+  deriving stock (Generic, Eq, Show)  inboxStatusText :: InboxStatus -> Text inboxStatusText = \case-    InboxProcessing -> "processing"-    InboxCompleted -> "completed"-    InboxFailed -> "failed"+  InboxProcessing -> "processing"+  InboxCompleted -> "completed"+  InboxFailed -> "failed"  parseInboxStatus :: Text -> Either Text InboxStatus parseInboxStatus = \case-    "processing" -> Right InboxProcessing-    "completed" -> Right InboxCompleted-    "failed" -> Right InboxFailed-    other -> Left ("unknown keiro_inbox.status: " <> other)+  "processing" -> Right InboxProcessing+  "completed" -> Right InboxCompleted+  "failed" -> Right InboxFailed+  other -> Left ("unknown keiro_inbox.status: " <> other) -{- | Compute the inbox dedupe key for an integration event under the-given policy plus optional Kafka delivery context. Returns 'Left' when-the policy demands a field the envelope does not carry (for example,-'PreferSourceEventIdentity' on an envelope with no-@sourceEventId@).--}+-- | Compute the inbox dedupe key for an integration event under the+-- given policy plus optional Kafka delivery context. Returns 'Left' when+-- the policy demands a field the envelope does not carry (for example,+-- 'PreferSourceEventIdentity' on an envelope with no+-- @sourceEventId@). dedupeKeyFor ::-    InboxDedupePolicy ->-    IntegrationEvent ->-    Maybe KafkaDeliveryRef ->-    Either InboxError Text+  InboxDedupePolicy ->+  IntegrationEvent ->+  Maybe KafkaDeliveryRef ->+  Either InboxError Text dedupeKeyFor policy event kafka = case policy of-    PreferIntegrationMessageId ->-        let mid = event ^. #messageId-         in if Text.null mid-                then Left (DedupePolicyUnsatisfied policy)-                else Right mid-    PreferSourceEventIdentity ->-        case event ^. #sourceEventId of-            Just (EventId u) -> Right (UUID.toText u)-            Nothing ->-                case event ^. #sourceGlobalPosition of-                    Just (GlobalPosition p) -> Right (Text.pack (show p))-                    Nothing -> Left (DedupePolicyUnsatisfied policy)-    KafkaDeliveryIdentity ->-        case kafka of-            Just ref ->-                Right-                    ( (ref ^. #topic)-                        <> ":"-                        <> Text.pack (show (ref ^. #partition))-                        <> ":"-                        <> Text.pack (show (ref ^. #offset))-                    )-            Nothing -> Left (DedupePolicyUnsatisfied policy)-    CustomDedupeKey k ->-        if Text.null k-            then Left (DedupePolicyUnsatisfied policy)-            else Right k+  PreferIntegrationMessageId ->+    let mid = event ^. #messageId+     in if Text.null mid+          then Left (DedupePolicyUnsatisfied policy)+          else Right mid+  PreferSourceEventIdentity ->+    case event ^. #sourceEventId of+      Just (EventId u) -> Right (UUID.toText u)+      Nothing ->+        case event ^. #sourceGlobalPosition of+          Just (GlobalPosition p) -> Right (Text.pack (show p))+          Nothing -> Left (DedupePolicyUnsatisfied policy)+  KafkaDeliveryIdentity ->+    case kafka of+      Just ref ->+        Right+          ( (ref ^. #topic)+              <> ":"+              <> Text.pack (show (ref ^. #partition))+              <> ":"+              <> Text.pack (show (ref ^. #offset))+          )+      Nothing -> Left (DedupePolicyUnsatisfied policy)+  CustomDedupeKey k ->+    if Text.null k+      then Left (DedupePolicyUnsatisfied policy)+      else Right k
src/Keiro/Outbox.hs view
@@ -1,37 +1,36 @@-{- | Durable integration-event outbox.--The outbox decouples "this service has decided to publish an integration-event" from "this service has actually published it". Two surfaces use-it:--* The canonical 'IntegrationProducer' helper maps durable private events-  to public 'Keiro.Integration.Event.IntegrationEvent' values and enqueues-  one outbox row per mapped event. It mints @messageId@ as a prefixed-  UUIDv7 (TypeID) so the id is time-ordered, human-readable, and stable-  across publish retries.-* 'enqueueOutboxTx' is the inline escape hatch for sagas and process-  managers that need to emit an integration event without an intermediate-  private domain event. It runs inside the caller's-  'Hasql.Transaction.Transaction'.--The 'publishClaimedOutbox' worker is transport-neutral. It claims rows-with @FOR UPDATE SKIP LOCKED@ plus the configured 'OrderingPolicy',-hands claimed batches to a caller-supplied publish function, and marks rows-sent, retryable, or dead. The Kafka adapter lives in-'Keiro.Outbox.Kafka'.--Run 'outboxMaintenancePass' on a separate, slower schedule to reclaim rows-left in @publishing@ by crashed workers and to sample the backlog gauge.--The per-key and per-source ordering policies sort by @created_at@, which-PostgreSQL fills at transaction start. The canonical 'IntegrationProducer'-subscription serializes same-key enqueues, so its ordering is stable. Callers-using the inline 'enqueueIntegrationEventTx' escape hatch concurrently for the-same key must serialize those enqueues themselves or accept best-effort order:-two transactions can commit in the opposite order of their @created_at@ values.--}-module Keiro.Outbox (-    -- * Re-exports+-- | Durable integration-event outbox.+--+-- The outbox decouples "this service has decided to publish an integration+-- event" from "this service has actually published it". Two surfaces use+-- it:+--+-- * The canonical 'IntegrationProducer' helper maps durable private events+--   to public 'Keiro.Integration.Event.IntegrationEvent' values and enqueues+--   one outbox row per mapped event. It mints @messageId@ as a prefixed+--   UUIDv7 (TypeID) so the id is time-ordered, human-readable, and stable+--   across publish retries.+-- * 'enqueueOutboxTx' is the inline escape hatch for sagas and process+--   managers that need to emit an integration event without an intermediate+--   private domain event. It runs inside the caller's+--   'Hasql.Transaction.Transaction'.+--+-- The 'publishClaimedOutbox' worker is transport-neutral. It claims rows+-- with @FOR UPDATE SKIP LOCKED@ plus the configured 'OrderingPolicy',+-- hands claimed batches to a caller-supplied publish function, and marks rows+-- sent, retryable, or dead. The Kafka adapter lives in+-- 'Keiro.Outbox.Kafka'.+--+-- Run 'outboxMaintenancePass' on a separate, slower schedule to reclaim rows+-- left in @publishing@ by crashed workers and to sample the backlog gauge.+--+-- The per-key and per-source ordering policies sort by @created_at@, which+-- PostgreSQL fills at transaction start. The canonical 'IntegrationProducer'+-- subscription serializes same-key enqueues, so its ordering is stable. Callers+-- using the inline 'enqueueIntegrationEventTx' escape hatch concurrently for the+-- same key must serialize those enqueues themselves or accept best-effort order:+-- two transactions can commit in the opposite order of their @created_at@ values.+module Keiro.Outbox+  ( -- * Re-exports     module Keiro.Outbox.Types,      -- * Storage primitives (transport-neutral)@@ -62,7 +61,7 @@     publishClaimedOutbox,     outboxMaintenancePass,     sampleOutboxBacklog,-)+  ) where  import Data.ByteString (ByteString)@@ -72,25 +71,25 @@ import Data.UUID.V7 qualified as V7 import Effectful (Eff, IOE, (:>)) import Effectful.Exception (displayException, trySync)-import Keiro.Integration.Event (-    IntegrationContentType,+import Keiro.Integration.Event+  ( IntegrationContentType,     IntegrationEvent (..),     SchemaReference,     TraceContext,- )+  ) import Keiro.Outbox.Kafka (outboxRowToKafkaRecord) import Keiro.Outbox.Schema import Keiro.Outbox.Types import Keiro.Prelude-import Keiro.Telemetry (-    KeiroMetrics,+import Keiro.Telemetry+  ( KeiroMetrics,     recordOutboxBacklog,     recordOutboxDeadlettered,     recordOutboxPublished,     recordOutboxReclaimed,     recordOutboxRetried,     withProducerSpan,- )+  ) import Kiroku.Store.Effect (Store) import Kiroku.Store.Transaction (runTransaction) import Kiroku.Store.Types (EventId, GlobalPosition, RecordedEvent)@@ -106,161 +105,156 @@ freshOutboxId :: (IOE :> es) => Eff es OutboxId freshOutboxId = fmap OutboxId (liftIO V7.genUUID) -{- | Enqueue an 'IntegrationEvent' from a saga or process manager that is-already running inside a 'runCommandWithSqlEvents' transaction. The-caller supplies a stable 'OutboxId' so retried command attempts coalesce-on the @(source, message_id)@ unique constraint.--Ordering caveat: under 'PerKeyHeadOfLine' and 'PerSourceStream', the publisher-orders rows by @created_at@, which PostgreSQL sets to transaction-start time.-If two concurrent transactions enqueue the same key/source and commit in the-opposite order, a publisher can observe that order. Serialize same-key enqueues-when strict order matters.--}+-- | Enqueue an 'IntegrationEvent' from a saga or process manager that is+-- already running inside a 'runCommandWithSqlEvents' transaction. The+-- caller supplies a stable 'OutboxId' so retried command attempts coalesce+-- on the @(source, message_id)@ unique constraint.+--+-- Ordering caveat: under 'PerKeyHeadOfLine' and 'PerSourceStream', the publisher+-- orders rows by @created_at@, which PostgreSQL sets to transaction-start time.+-- If two concurrent transactions enqueue the same key/source and commit in the+-- opposite order, a publisher can observe that order. Serialize same-key enqueues+-- when strict order matters. enqueueIntegrationEventTx ::-    OutboxId ->-    IntegrationEvent ->-    Tx.Transaction ()+  OutboxId ->+  IntegrationEvent ->+  Tx.Transaction () enqueueIntegrationEventTx outboxId event =-    enqueueOutboxTx (OutboxMessage{outboxId, event})+  enqueueOutboxTx (OutboxMessage {outboxId, event})  -- --------------------------------------------------------------------------- -- Producer-subscription helper -- --------------------------------------------------------------------------- -{- | Configuration for the canonical producer subscription.--A service running 'IntegrationProducer' reads its private event stream,-decodes each event with a 'Keiro.Codec.Codec', calls 'mapEvent', and for-each 'Just' result writes one 'keiro_outbox' row. The helper mints-@messageId@ on each insert so the id is stable across publish retries.--* 'name' — subscription name used to checkpoint the producer's cursor-  in the @subscriptions@ table.-* 'source' — value written into @keiro_outbox.source@; identifies the-  producing bounded context.-* 'messageIdPrefix' — TypeID prefix used when minting @messageId@.-  Must be 1-63 lowercase Latin letters (e.g. @\"msg\"@, @\"order\"@).-  Prefer constructing producers with 'mkIntegrationProducer'; an invalid-  prefix passed directly to 'IntegrationProducer' raises when the first-  message id is minted.-* 'mapEvent' — pure mapper from a private 'RecordedEvent' and its-  decoded payload to an 'IntegrationEventDraft'. Returning 'Nothing'-  skips the event without enqueuing a row.--}+-- | Configuration for the canonical producer subscription.+--+-- A service running 'IntegrationProducer' reads its private event stream,+-- decodes each event with a 'Keiro.Codec.Codec', calls 'mapEvent', and for+-- each 'Just' result writes one 'keiro_outbox' row. The helper mints+-- @messageId@ on each insert so the id is stable across publish retries.+--+-- * 'name' — subscription name used to checkpoint the producer's cursor+--   in the @subscriptions@ table.+-- * 'source' — value written into @keiro_outbox.source@; identifies the+--   producing bounded context.+-- * 'messageIdPrefix' — TypeID prefix used when minting @messageId@.+--   Must be 1-63 lowercase Latin letters (e.g. @\"msg\"@, @\"order\"@).+--   Prefer constructing producers with 'mkIntegrationProducer'; an invalid+--   prefix passed directly to 'IntegrationProducer' raises when the first+--   message id is minted.+-- * 'mapEvent' — pure mapper from a private 'RecordedEvent' and its+--   decoded payload to an 'IntegrationEventDraft'. Returning 'Nothing'+--   skips the event without enqueuing a row. data IntegrationProducer e = IntegrationProducer-    { name :: !Text-    , source :: !Text-    , messageIdPrefix :: !Text-    , mapEvent :: !(RecordedEvent -> e -> Maybe IntegrationEventDraft)-    }-    deriving stock (Generic)+  { name :: !Text,+    source :: !Text,+    messageIdPrefix :: !Text,+    mapEvent :: !(RecordedEvent -> e -> Maybe IntegrationEventDraft)+  }+  deriving stock (Generic)  data IntegrationProducerConfigError-    = InvalidMessageIdPrefix !Text !Text-    deriving stock (Generic, Eq, Show)+  = InvalidMessageIdPrefix !Text !Text+  deriving stock (Generic, Eq, Show)  -- | Validate an integration producer before starting its subscription. mkIntegrationProducer :: IntegrationProducer e -> Either IntegrationProducerConfigError (IntegrationProducer e) mkIntegrationProducer producer =-    case TypeID.checkPrefix (producer ^. #messageIdPrefix) of-        Nothing -> Right producer-        Just err ->-            Left-                ( InvalidMessageIdPrefix-                    (producer ^. #messageIdPrefix)-                    (Text.pack (show err))-                )--{- | Everything in 'IntegrationEvent' except 'messageId' and 'source' —-those are filled in by 'mintIntegrationEvent' from the producer-configuration and the freshly minted TypeID.+  case TypeID.checkPrefix (producer ^. #messageIdPrefix) of+    Nothing -> Right producer+    Just err ->+      Left+        ( InvalidMessageIdPrefix+            (producer ^. #messageIdPrefix)+            (Text.pack (show err))+        ) -@sourceEventId@ and @sourceGlobalPosition@ default to the values on the-underlying 'RecordedEvent' (see 'mintIntegrationEvent'); a mapper that-needs to override them can replace the draft fields directly.--}+-- | Everything in 'IntegrationEvent' except 'messageId' and 'source' —+-- those are filled in by 'mintIntegrationEvent' from the producer+-- configuration and the freshly minted TypeID.+--+-- @sourceEventId@ and @sourceGlobalPosition@ default to the values on the+-- underlying 'RecordedEvent' (see 'mintIntegrationEvent'); a mapper that+-- needs to override them can replace the draft fields directly. data IntegrationEventDraft = IntegrationEventDraft-    { destination :: !Text-    , key :: !(Maybe Text)-    , eventType :: !Text-    , schemaVersion :: !Int-    , contentType :: !IntegrationContentType-    , schemaReference :: !(Maybe SchemaReference)-    , sourceEventId :: !(Maybe EventId)-    , sourceGlobalPosition :: !(Maybe GlobalPosition)-    , payloadBytes :: !ByteString-    , occurredAt :: !UTCTime-    , causationId :: !(Maybe EventId)-    , correlationId :: !(Maybe EventId)-    , traceContext :: !(Maybe TraceContext)-    , attributes :: !(Maybe Value)-    }-    deriving stock (Generic, Eq, Show)+  { destination :: !Text,+    key :: !(Maybe Text),+    eventType :: !Text,+    schemaVersion :: !Int,+    contentType :: !IntegrationContentType,+    schemaReference :: !(Maybe SchemaReference),+    sourceEventId :: !(Maybe EventId),+    sourceGlobalPosition :: !(Maybe GlobalPosition),+    payloadBytes :: !ByteString,+    occurredAt :: !UTCTime,+    causationId :: !(Maybe EventId),+    correlationId :: !(Maybe EventId),+    traceContext :: !(Maybe TraceContext),+    attributes :: !(Maybe Value)+  }+  deriving stock (Generic, Eq, Show) -{- | Mint a fresh @messageId@ (TypeID with the producer's prefix) and build-the full 'IntegrationEvent' from the draft. Lives in 'IO' because TypeID-generation reads the global UUIDv7 sequence counter.--}+-- | Mint a fresh @messageId@ (TypeID with the producer's prefix) and build+-- the full 'IntegrationEvent' from the draft. Lives in 'IO' because TypeID+-- generation reads the global UUIDv7 sequence counter. mintIntegrationEvent ::-    (IOE :> es) =>-    IntegrationProducer e ->-    IntegrationEventDraft ->-    Eff es IntegrationEvent+  (IOE :> es) =>+  IntegrationProducer e ->+  IntegrationEventDraft ->+  Eff es IntegrationEvent mintIntegrationEvent producer draft = do-    typeId <- liftIO (TypeID.genTypeID (producer ^. #messageIdPrefix))-    pure (draftToEvent (producer ^. #source) (TypeID.toText typeId) draft)+  typeId <- liftIO (TypeID.genTypeID (producer ^. #messageIdPrefix))+  pure (draftToEvent (producer ^. #source) (TypeID.toText typeId) draft)  -- | Build an 'IntegrationEvent' from a source, a minted message id, and a draft. draftToEvent :: Text -> Text -> IntegrationEventDraft -> IntegrationEvent draftToEvent source minted draft =-    IntegrationEvent-        { messageId = minted-        , source-        , destination = draft ^. #destination-        , key = draft ^. #key-        , eventType = draft ^. #eventType-        , schemaVersion = draft ^. #schemaVersion-        , contentType = draft ^. #contentType-        , schemaReference = draft ^. #schemaReference-        , sourceEventId = draft ^. #sourceEventId-        , sourceGlobalPosition = draft ^. #sourceGlobalPosition-        , payloadBytes = draft ^. #payloadBytes-        , occurredAt = draft ^. #occurredAt-        , causationId = draft ^. #causationId-        , correlationId = draft ^. #correlationId-        , traceContext = draft ^. #traceContext-        , attributes = draft ^. #attributes-        }--{- | Enqueue one drafted producer event inside an existing transaction.--This is the primitive a subscription worker calls per event. It mints a-fresh @messageId@ (TypeID), constructs the full envelope, and inserts-the row. The caller supplies the 'OutboxId' so retries from a known-subscription cursor coalesce on @(source, message_id)@.--The TypeID is minted before the insert; if the transaction rolls back-the message id is discarded (no observable effect) and the next attempt-mints a different id. Idempotency at the row level relies on a stable-'OutboxId', not the minted message id.+  IntegrationEvent+    { messageId = minted,+      source,+      destination = draft ^. #destination,+      key = draft ^. #key,+      eventType = draft ^. #eventType,+      schemaVersion = draft ^. #schemaVersion,+      contentType = draft ^. #contentType,+      schemaReference = draft ^. #schemaReference,+      sourceEventId = draft ^. #sourceEventId,+      sourceGlobalPosition = draft ^. #sourceGlobalPosition,+      payloadBytes = draft ^. #payloadBytes,+      occurredAt = draft ^. #occurredAt,+      causationId = draft ^. #causationId,+      correlationId = draft ^. #correlationId,+      traceContext = draft ^. #traceContext,+      attributes = draft ^. #attributes+    } -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.--}+-- | Enqueue one drafted producer event inside an existing transaction.+--+-- This is the primitive a subscription worker calls per event. It mints a+-- fresh @messageId@ (TypeID), constructs the full envelope, and inserts+-- the row. The caller supplies the 'OutboxId' so retries from a known+-- subscription cursor coalesce on @(source, message_id)@.+--+-- The TypeID is minted before the insert; if the transaction rolls back+-- the message id is discarded (no observable effect) and the next attempt+-- mints a different id. Idempotency at the row level relies on a stable+-- 'OutboxId', not the minted message id.+--+-- Ordering caveat: @created_at@ records transaction-start time. Under+-- 'PerKeyHeadOfLine' or 'PerSourceStream', concurrent transactions for the same+-- key/source can commit in the opposite order and are therefore best-effort+-- unless the caller serializes them. The canonical producer subscription does+-- serialize same-key enqueues. enqueueProducerEventTx ::-    forall e es.-    (IOE :> es) =>-    IntegrationProducer e ->-    OutboxId ->-    IntegrationEventDraft ->-    Eff es (Tx.Transaction ())+  forall e es.+  (IOE :> es) =>+  IntegrationProducer e ->+  OutboxId ->+  IntegrationEventDraft ->+  Eff es (Tx.Transaction ()) enqueueProducerEventTx producer outboxId draft = do-    event <- mintIntegrationEvent producer draft-    pure (enqueueOutboxTx (OutboxMessage{outboxId, event}))+  event <- mintIntegrationEvent producer draft+  pure (enqueueOutboxTx (OutboxMessage {outboxId, event}))  -- --------------------------------------------------------------------------- -- Publisher worker@@ -268,133 +262,132 @@  -- | Result of one publish attempt as reported by the transport-specific publisher. data PublishOutcome-    = -- | Kafka acknowledged the publish.-      PublishSucceeded-    | -- | Publish failed; will be retried after the configured backoff.-      PublishFailed !Text-    deriving stock (Generic, Eq, Show)--{- | Drain claimed outbox rows by handing the claimed batch to @publish@ and-reflecting the outcomes back into row statuses.--Claims rows in batches of @batchSize@ under the active 'OrderingPolicy',-calls @publish@ with the claimed rows in claim order, and marks every row-sent or — using 'markOutboxFailedTx' — failed/dead. The publish result must-contain one outcome per input row; a missing outcome is treated as-@PublishFailed "publisher returned no outcome"@. If the publisher throws,-every row in that call is treated as failed with the exception text.--For ordered policies, if a row fails then later rows in the same ordered group-are skipped and returned to @failed@ without consuming an attempt; these-skipped rows count as 'OutboxPublishSummary.retried'. A real Kafka transport-must not successfully deliver a later same-key record after reporting an-earlier same-key failure from the same call. On 'StopTheLine', the worker calls-@publish@ with singleton batches and halts after the first failed row, recording-the offending 'OutboxId' in 'haltedOn'.--Returns when one of:--* No rows are claimable.-* The active policy is 'StopTheLine' and a publish failed.+  = -- | Kafka acknowledged the publish.+    PublishSucceeded+  | -- | Publish failed; will be retried after the configured backoff.+    PublishFailed !Text+  deriving stock (Generic, Eq, Show) -The worker does not loop indefinitely; the application is expected to-schedule it repeatedly (e.g. once per process-compose tick).--}+-- | Drain claimed outbox rows by handing the claimed batch to @publish@ and+-- reflecting the outcomes back into row statuses.+--+-- Claims rows in batches of @batchSize@ under the active 'OrderingPolicy',+-- calls @publish@ with the claimed rows in claim order, and marks every row+-- sent or — using 'markOutboxFailedTx' — failed/dead. The publish result must+-- contain one outcome per input row; a missing outcome is treated as+-- @PublishFailed "publisher returned no outcome"@. If the publisher throws,+-- every row in that call is treated as failed with the exception text.+--+-- For ordered policies, if a row fails then later rows in the same ordered group+-- are skipped and returned to @failed@ without consuming an attempt; these+-- skipped rows count as 'OutboxPublishSummary.retried'. A real Kafka transport+-- must not successfully deliver a later same-key record after reporting an+-- earlier same-key failure from the same call. On 'StopTheLine', the worker calls+-- @publish@ with singleton batches and halts after the first failed row, recording+-- the offending 'OutboxId' in 'haltedOn'.+--+-- Returns when one of:+--+-- * No rows are claimable.+-- * The active policy is 'StopTheLine' and a publish failed.+--+-- The worker does not loop indefinitely; the application is expected to+-- schedule it repeatedly (e.g. once per process-compose tick). publishClaimedOutbox ::-    forall es.-    (IOE :> es, Store :> es) =>-    ([OutboxRow] -> Eff es [(OutboxId, PublishOutcome)]) ->-    OutboxPublishOptions ->-    Maybe KeiroMetrics ->-    Eff es OutboxPublishSummary+  forall es.+  (IOE :> es, Store :> es) =>+  ([OutboxRow] -> Eff es [(OutboxId, PublishOutcome)]) ->+  OutboxPublishOptions ->+  Maybe KeiroMetrics ->+  Eff es OutboxPublishSummary publishClaimedOutbox publish options mMetrics = do-    now <- liftIO getCurrentTime-    rows <- claimOutboxBatch (options ^. #orderingPolicy) (options ^. #batchSize) now-    summary <- publishBatch rows-    -- Counters from the aggregated pass summary (each a no-op under 'Nothing';-    -- a zero delta is harmless).-    recordOutboxPublished mMetrics (fromIntegral (summary ^. #published))-    recordOutboxRetried mMetrics (fromIntegral (summary ^. #retried))-    recordOutboxDeadlettered mMetrics (fromIntegral (summary ^. #dead))-    pure summary+  now <- liftIO getCurrentTime+  rows <- claimOutboxBatch (options ^. #orderingPolicy) (options ^. #batchSize) now+  summary <- publishBatch rows+  -- Counters from the aggregated pass summary (each a no-op under 'Nothing';+  -- a zero delta is harmless).+  recordOutboxPublished mMetrics (fromIntegral (summary ^. #published))+  recordOutboxRetried mMetrics (fromIntegral (summary ^. #retried))+  recordOutboxDeadlettered mMetrics (fromIntegral (summary ^. #dead))+  pure summary   where     publishBatch :: [OutboxRow] -> Eff es OutboxPublishSummary     publishBatch [] =-        pure OutboxPublishSummary{claimed = 0, published = 0, retried = 0, dead = 0, haltedOn = Nothing}+      pure OutboxPublishSummary {claimed = 0, published = 0, retried = 0, dead = 0, haltedOn = Nothing}     publishBatch batch =-        case options ^. #orderingPolicy of-            StopTheLine -> publishStopTheLine batch batch [] Nothing-            policy -> do-                outcomes <- publishRows batch-                markProcessedOutcomes policy batch outcomes Nothing+      case options ^. #orderingPolicy of+        StopTheLine -> publishStopTheLine batch batch [] Nothing+        policy -> do+          outcomes <- publishRows batch+          markProcessedOutcomes policy batch outcomes Nothing      publishStopTheLine ::-        [OutboxRow] ->-        [OutboxRow] ->-        [(OutboxId, PublishOutcome)] ->-        Maybe OutboxId ->-        Eff es OutboxPublishSummary+      [OutboxRow] ->+      [OutboxRow] ->+      [(OutboxId, PublishOutcome)] ->+      Maybe OutboxId ->+      Eff es OutboxPublishSummary     publishStopTheLine original [] outcomes halted =-        markProcessedOutcomes StopTheLine original (Map.fromList outcomes) halted+      markProcessedOutcomes StopTheLine original (Map.fromList outcomes) halted     publishStopTheLine original (row : rest) outcomes _ = do-        result <- publishRows [row]-        let outcome = outcomeFor result row-            outcomes' = outcomes <> [(row ^. #outboxId, outcome)]-        case outcome of-            PublishSucceeded -> publishStopTheLine original rest outcomes' Nothing-            PublishFailed _ -> markProcessedOutcomes StopTheLine original (Map.fromList outcomes') (Just (row ^. #outboxId))+      result <- publishRows [row]+      let outcome = outcomeFor result row+          outcomes' = outcomes <> [(row ^. #outboxId, outcome)]+      case outcome of+        PublishSucceeded -> publishStopTheLine original rest outcomes' Nothing+        PublishFailed _ -> markProcessedOutcomes StopTheLine original (Map.fromList outcomes') (Just (row ^. #outboxId))      publishRows :: [OutboxRow] -> Eff es (Map.Map OutboxId PublishOutcome)     publishRows [] = pure Map.empty     publishRows batch@(firstRow : _) =-        Map.fromList-            <$> withBatchSpan-                batch-                firstRow-                ( do-                    attempted <- trySync (publish batch)-                    let normalized =-                            case attempted of-                                Left err ->-                                    let errMsg = Text.pack (displayException err)-                                     in [(row ^. #outboxId, PublishFailed errMsg) | row <- batch]-                                Right reported ->-                                    normalizeOutcomes batch reported-                    pure normalized-                )+      Map.fromList+        <$> withBatchSpan+          batch+          firstRow+          ( do+              attempted <- trySync (publish batch)+              let normalized =+                    case attempted of+                      Left err ->+                        let errMsg = Text.pack (displayException err)+                         in [(row ^. #outboxId, PublishFailed errMsg) | row <- batch]+                      Right reported ->+                        normalizeOutcomes batch reported+              pure normalized+          )      withBatchSpan ::-        [OutboxRow] ->-        OutboxRow ->-        Eff es [(OutboxId, PublishOutcome)] ->-        Eff es [(OutboxId, PublishOutcome)]+      [OutboxRow] ->+      OutboxRow ->+      Eff es [(OutboxId, PublishOutcome)] ->+      Eff es [(OutboxId, PublishOutcome)]     withBatchSpan batch firstRow action =-        withProducerSpan-            (options ^. #tracer)-            (firstRow ^. #event)-            (outboxRowToKafkaRecord firstRow)-            $ \mSpan -> do-                for_ mSpan $ \sp ->-                    addAttribute sp (unkey keiro_outbox_batch_size) (fromIntegral (length batch) :: Int64)-                outcomes <- action-                case (mSpan, firstFailure outcomes) of-                    (Just sp, Just errMsg) -> do-                        addAttribute sp (unkey error_type) ("publish_failed" :: Text)-                        setStatus sp (Error errMsg)-                    _ -> pure ()-                pure outcomes+      withProducerSpan+        (options ^. #tracer)+        (firstRow ^. #event)+        (outboxRowToKafkaRecord firstRow)+        $ \mSpan -> do+          for_ mSpan $ \sp ->+            addAttribute sp (unkey keiro_outbox_batch_size) (fromIntegral (length batch) :: Int64)+          outcomes <- action+          case (mSpan, firstFailure outcomes) of+            (Just sp, Just errMsg) -> do+              addAttribute sp (unkey error_type) ("publish_failed" :: Text)+              setStatus sp (Error errMsg)+            _ -> pure ()+          pure outcomes      normalizeOutcomes :: [OutboxRow] -> [(OutboxId, PublishOutcome)] -> [(OutboxId, PublishOutcome)]     normalizeOutcomes batch reported =-        let reportedMap = Map.fromList reported-         in [ (row ^. #outboxId, outcomeFor reportedMap row)-            | row <- batch-            ]+      let reportedMap = Map.fromList reported+       in [ (row ^. #outboxId, outcomeFor reportedMap row)+          | row <- batch+          ]      outcomeFor :: Map.Map OutboxId PublishOutcome -> OutboxRow -> PublishOutcome     outcomeFor outcomes row =-        fromMaybe (PublishFailed "publisher returned no outcome") $-            Map.lookup (row ^. #outboxId) outcomes+      fromMaybe (PublishFailed "publisher returned no outcome") $+        Map.lookup (row ^. #outboxId) outcomes      firstFailure :: [(OutboxId, PublishOutcome)] -> Maybe Text     firstFailure [] = Nothing@@ -402,152 +395,151 @@     firstFailure ((_, PublishFailed errMsg) : _) = Just errMsg      markProcessedOutcomes ::-        OrderingPolicy ->-        [OutboxRow] ->-        Map.Map OutboxId PublishOutcome ->-        Maybe OutboxId ->-        Eff es OutboxPublishSummary+      OrderingPolicy ->+      [OutboxRow] ->+      Map.Map OutboxId PublishOutcome ->+      Maybe OutboxId ->+      Eff es OutboxPublishSummary     markProcessedOutcomes policy batch outcomes halted = do-        now <- liftIO getCurrentTime-        let marks = foldMap (groupMarks outcomes) (outcomeGroups policy batch)-            sentIds = marks ^. #sentIds-            failedRows = marks ^. #failedRows-            skippedRows = marks ^. #skippedRows-        failedStatuses <--            if null failedRows && null skippedRows-                then pure []-                else runTransaction $ do-                    statuses <- traverse (markFailed now) failedRows-                    traverse_ (markSkipped now) skippedRows-                    pure statuses-        _ <- markOutboxSentBatch sentIds now-        let deadCount = length [() | OutboxDead <- failedStatuses]-            retriedFailures = length failedStatuses - deadCount-        pure-            OutboxPublishSummary-                { claimed = length batch-                , published = length sentIds-                , retried = retriedFailures + length skippedRows-                , dead = deadCount-                , haltedOn = halted-                }+      now <- liftIO getCurrentTime+      let marks = foldMap (groupMarks outcomes) (outcomeGroups policy batch)+          sentIds = marks ^. #sentIds+          failedRows = marks ^. #failedRows+          skippedRows = marks ^. #skippedRows+      failedStatuses <-+        if null failedRows && null skippedRows+          then pure []+          else runTransaction $ do+            statuses <- traverse (markFailed now) failedRows+            traverse_ (markSkipped now) skippedRows+            pure statuses+      _ <- markOutboxSentBatch sentIds now+      let deadCount = length [() | OutboxDead <- failedStatuses]+          retriedFailures = length failedStatuses - deadCount+      pure+        OutboxPublishSummary+          { claimed = length batch,+            published = length sentIds,+            retried = retriedFailures + length skippedRows,+            dead = deadCount,+            haltedOn = halted+          }      markFailed :: UTCTime -> (OutboxRow, Text) -> Tx.Transaction OutboxStatus     markFailed now (row, errMsg) =-        markOutboxFailedTx-            (row ^. #outboxId)-            errMsg-            (options ^. #maxAttempts)-            (nextDelay (options ^. #backoff) (row ^. #attemptCount))-            now+      markOutboxFailedTx+        (row ^. #outboxId)+        errMsg+        (options ^. #maxAttempts)+        (nextDelay (options ^. #backoff) (row ^. #attemptCount))+        now      markSkipped :: UTCTime -> OutboxRow -> Tx.Transaction ()     markSkipped now row =-        markOutboxSkippedTx-            (row ^. #outboxId)-            "skipped: earlier record for the same key failed"-            now--{- | Reclaim crashed publisher rows and record the outbox backlog gauge.+      markOutboxSkippedTx+        (row ^. #outboxId)+        "skipped: earlier record for the same key failed"+        now -Schedule this pass independently from 'publishClaimedOutbox', typically on a-slower timer. It is the only library worker path that reclaims rows stranded in-@publishing@.--}+-- | Reclaim crashed publisher rows and record the outbox backlog gauge.+--+-- Schedule this pass independently from 'publishClaimedOutbox', typically on a+-- slower timer. It is the only library worker path that reclaims rows stranded in+-- @publishing@. outboxMaintenancePass ::-    (IOE :> es, Store :> es) =>-    OutboxMaintenanceOptions ->-    Maybe KeiroMetrics ->-    Eff es OutboxMaintenanceSummary+  (IOE :> es, Store :> es) =>+  OutboxMaintenanceOptions ->+  Maybe KeiroMetrics ->+  Eff es OutboxMaintenanceSummary outboxMaintenancePass options mMetrics = do-    now <- liftIO getCurrentTime-    (requeued, deadLettered) <--        requeueStuckOutbox-            (options ^. #maxAttempts)-            (options ^. #publishingTimeout)-            now-    recordOutboxReclaimed mMetrics (fromIntegral requeued)-    recordOutboxDeadlettered mMetrics (fromIntegral deadLettered)-    backlog <- countOutboxBacklog-    recordOutboxBacklog mMetrics (fromIntegral backlog)-    pure OutboxMaintenanceSummary{requeued, deadLettered, backlog}+  now <- liftIO getCurrentTime+  (requeued, deadLettered) <-+    requeueStuckOutbox+      (options ^. #maxAttempts)+      (options ^. #publishingTimeout)+      now+  recordOutboxReclaimed mMetrics (fromIntegral requeued)+  recordOutboxDeadlettered mMetrics (fromIntegral deadLettered)+  backlog <- countOutboxBacklog+  recordOutboxBacklog mMetrics (fromIntegral backlog)+  pure OutboxMaintenanceSummary {requeued, deadLettered, backlog}  -- | Count publishable rows and record the outbox backlog gauge when metrics are enabled. sampleOutboxBacklog :: (IOE :> es, Store :> es) => Maybe KeiroMetrics -> Eff es () sampleOutboxBacklog Nothing = pure () sampleOutboxBacklog (Just metrics) = do-    backlog <- countOutboxBacklog-    recordOutboxBacklog (Just metrics) (fromIntegral backlog)+  backlog <- countOutboxBacklog+  recordOutboxBacklog (Just metrics) (fromIntegral backlog)  data OutcomeMarks = OutcomeMarks-    { sentIds :: ![OutboxId]-    , failedRows :: ![(OutboxRow, Text)]-    , skippedRows :: ![OutboxRow]-    }-    deriving stock (Generic)+  { sentIds :: ![OutboxId],+    failedRows :: ![(OutboxRow, Text)],+    skippedRows :: ![OutboxRow]+  }+  deriving stock (Generic)  instance Semigroup OutcomeMarks where-    left <> right =-        OutcomeMarks-            { sentIds = (left ^. #sentIds) <> (right ^. #sentIds)-            , failedRows = (left ^. #failedRows) <> (right ^. #failedRows)-            , skippedRows = (left ^. #skippedRows) <> (right ^. #skippedRows)-            }+  left <> right =+    OutcomeMarks+      { sentIds = (left ^. #sentIds) <> (right ^. #sentIds),+        failedRows = (left ^. #failedRows) <> (right ^. #failedRows),+        skippedRows = (left ^. #skippedRows) <> (right ^. #skippedRows)+      }  instance Monoid OutcomeMarks where-    mempty = OutcomeMarks{sentIds = [], failedRows = [], skippedRows = []}+  mempty = OutcomeMarks {sentIds = [], failedRows = [], skippedRows = []}  groupMarks :: Map.Map OutboxId PublishOutcome -> [OutboxRow] -> OutcomeMarks groupMarks outcomes = go []   where-    go sent [] = mempty{sentIds = sent}+    go sent [] = mempty {sentIds = sent}     go sent (row : rest) =-        case fromMaybe (PublishFailed "publisher returned no outcome") (Map.lookup (row ^. #outboxId) outcomes) of-            PublishSucceeded -> go (sent <> [row ^. #outboxId]) rest-            PublishFailed errMsg ->-                OutcomeMarks-                    { sentIds = sent-                    , failedRows = [(row, errMsg)]-                    , skippedRows = rest-                    }+      case fromMaybe (PublishFailed "publisher returned no outcome") (Map.lookup (row ^. #outboxId) outcomes) of+        PublishSucceeded -> go (sent <> [row ^. #outboxId]) rest+        PublishFailed errMsg ->+          OutcomeMarks+            { sentIds = sent,+              failedRows = [(row, errMsg)],+              skippedRows = rest+            }  data OutcomeGroupKey-    = BatchGroup-    | SourceGroup !Text-    | RowGroup !OutboxId-    | KeyGroup !Text !Text-    deriving stock (Generic, Eq)+  = BatchGroup+  | SourceGroup !Text+  | RowGroup !OutboxId+  | KeyGroup !Text !Text+  deriving stock (Generic, Eq)  data OutcomeGroup = OutcomeGroup-    { groupKey :: !OutcomeGroupKey-    , groupRows :: ![OutboxRow]-    }-    deriving stock (Generic)+  { groupKey :: !OutcomeGroupKey,+    groupRows :: ![OutboxRow]+  }+  deriving stock (Generic)  outcomeGroups :: OrderingPolicy -> [OutboxRow] -> [[OutboxRow]] outcomeGroups policy =-    fmap (^. #groupRows) . foldl' addGroup []+  fmap (^. #groupRows) . foldl' addGroup []   where     addGroup groups row =-        appendGroup (keyFor row) row groups+      appendGroup (keyFor row) row groups     keyFor row =-        case policy of-            -- A claimed batch can hold runs from several independent sources;-            -- a failure in one source's run must not skip another source's rows.-            PerSourceStream -> SourceGroup (row ^. #event . #source)-            -- Deliberately one group: any failure halts the worker, and the-            -- entire remaining batch is skipped without consuming attempts.-            StopTheLine -> BatchGroup-            BestEffort -> RowGroup (row ^. #outboxId)-            _ ->-                case row ^. #event . #key of-                    Nothing -> RowGroup (row ^. #outboxId)-                    Just key -> KeyGroup (row ^. #event . #source) key+      case policy of+        -- A claimed batch can hold runs from several independent sources;+        -- a failure in one source's run must not skip another source's rows.+        PerSourceStream -> SourceGroup (row ^. #event . #source)+        -- Deliberately one group: any failure halts the worker, and the+        -- entire remaining batch is skipped without consuming attempts.+        StopTheLine -> BatchGroup+        BestEffort -> RowGroup (row ^. #outboxId)+        _ ->+          case row ^. #event . #key of+            Nothing -> RowGroup (row ^. #outboxId)+            Just key -> KeyGroup (row ^. #event . #source) key  appendGroup :: OutcomeGroupKey -> OutboxRow -> [OutcomeGroup] -> [OutcomeGroup]-appendGroup key row [] = [OutcomeGroup{groupKey = key, groupRows = [row]}]+appendGroup key row [] = [OutcomeGroup {groupKey = key, groupRows = [row]}] appendGroup key row (group : rest)-    | group ^. #groupKey == key =-        (group & #groupRows %~ (<> [row])) : rest-    | otherwise =-        group : appendGroup key row rest+  | group ^. #groupKey == key =+      (group & #groupRows %~ (<> [row])) : rest+  | otherwise =+      group : appendGroup key row rest
src/Keiro/Outbox/Kafka.hs view
@@ -1,27 +1,26 @@-{- | Transport-neutral Kafka representation for outbox rows.--This module owns the conversion from 'Keiro.Outbox.Types.OutboxRow' to a-neutral 'KafkaProducerRecord' value. It deliberately does not import-@hw-kafka-client@ or @kafka-effectful@: keiro itself remains free of-librdkafka system-library requirements. The integration test package-(EP-22) bridges 'KafkaProducerRecord' to-@Kafka.Producer.Types.ProducerRecord@ from @hw-kafka-client@ inside its-own dependency scope.--A 'KafkaProducerRecord' carries everything the broker layer needs:-topic, optional partition key, the raw payload bytes from the EP-19-envelope, and the canonical header set. Building the record is pure;-publishing is the caller's responsibility.--The outbox worker opens one producer span around each claimed publish batch.-Adapters that need per-record broker visibility should add their own spans-around the actual Kafka produce calls.--}-module Keiro.Outbox.Kafka (-    KafkaProducerRecord (..),+-- | Transport-neutral Kafka representation for outbox rows.+--+-- This module owns the conversion from 'Keiro.Outbox.Types.OutboxRow' to a+-- neutral 'KafkaProducerRecord' value. It deliberately does not import+-- @hw-kafka-client@ or @kafka-effectful@: keiro itself remains free of+-- librdkafka system-library requirements. The integration test package+-- (EP-22) bridges 'KafkaProducerRecord' to+-- @Kafka.Producer.Types.ProducerRecord@ from @hw-kafka-client@ inside its+-- own dependency scope.+--+-- A 'KafkaProducerRecord' carries everything the broker layer needs:+-- topic, optional partition key, the raw payload bytes from the EP-19+-- envelope, and the canonical header set. Building the record is pure;+-- publishing is the caller's responsibility.+--+-- The outbox worker opens one producer span around each claimed publish batch.+-- Adapters that need per-record broker visibility should add their own spans+-- around the actual Kafka produce calls.+module Keiro.Outbox.Kafka+  ( KafkaProducerRecord (..),     outboxRowToKafkaRecord,     integrationEventToKafkaRecord,-)+  ) where  import Data.ByteString (ByteString)@@ -30,30 +29,29 @@ import Keiro.Outbox.Types (OutboxRow (..)) import Keiro.Prelude -{- | A neutral Kafka producer record.--Fields:--* 'topic' — Kafka topic, taken from 'IntegrationEvent.destination'.-* 'key' — partition key bytes (UTF-8 encoded). 'Nothing' means-  Kafka round-robins the record across partitions and skips per-key-  ordering.-* 'payload' — exactly the bytes from-  'Keiro.Integration.Event.integrationPayload'.-* 'headers' — UTF-8 encoded view of-  'Keiro.Integration.Event.integrationHeaders'.--The byte encoding for keys and headers is UTF-8 by convention; Kafka-treats both as opaque bytes, so a future binary-key transport can drop-the encoding by populating 'key' directly.--}+-- | A neutral Kafka producer record.+--+-- Fields:+--+-- * 'topic' — Kafka topic, taken from 'IntegrationEvent.destination'.+-- * 'key' — partition key bytes (UTF-8 encoded). 'Nothing' means+--   Kafka round-robins the record across partitions and skips per-key+--   ordering.+-- * 'payload' — exactly the bytes from+--   'Keiro.Integration.Event.integrationPayload'.+-- * 'headers' — UTF-8 encoded view of+--   'Keiro.Integration.Event.integrationHeaders'.+--+-- The byte encoding for keys and headers is UTF-8 by convention; Kafka+-- treats both as opaque bytes, so a future binary-key transport can drop+-- the encoding by populating 'key' directly. data KafkaProducerRecord = KafkaProducerRecord-    { topic :: !Text-    , key :: !(Maybe ByteString)-    , payload :: !ByteString-    , headers :: ![(ByteString, ByteString)]-    }-    deriving stock (Generic, Eq, Show)+  { topic :: !Text,+    key :: !(Maybe ByteString),+    payload :: !ByteString,+    headers :: ![(ByteString, ByteString)]+  }+  deriving stock (Generic, Eq, Show)  -- | Build a 'KafkaProducerRecord' from a published outbox row. outboxRowToKafkaRecord :: OutboxRow -> KafkaProducerRecord@@ -62,9 +60,9 @@ -- | Build a 'KafkaProducerRecord' directly from an 'IntegrationEvent'. integrationEventToKafkaRecord :: IntegrationEvent -> KafkaProducerRecord integrationEventToKafkaRecord event =-    KafkaProducerRecord-        { topic = event ^. #destination-        , key = fmap TE.encodeUtf8 (event ^. #key)-        , payload = integrationPayload event-        , headers = [(TE.encodeUtf8 n, TE.encodeUtf8 v) | (n, v) <- integrationHeaders event]-        }+  KafkaProducerRecord+    { topic = event ^. #destination,+      key = fmap TE.encodeUtf8 (event ^. #key),+      payload = integrationPayload event,+      headers = [(TE.encodeUtf8 n, TE.encodeUtf8 v) | (n, v) <- integrationHeaders event]+    }
src/Keiro/Outbox/Schema.hs view
@@ -1,811 +1,799 @@ {-# LANGUAGE ApplicativeDo #-} -{- | Hasql-level storage for the durable integration-event outbox.--This module owns the SQL surface that publishers call into. Higher-level-helpers ('Keiro.Outbox') and transport adapters-('Keiro.Outbox.Kafka') consume these primitives.--}-module Keiro.Outbox.Schema (-    enqueueOutboxTx,-    claimOutboxBatch,-    requeueStuckOutbox,-    markOutboxSent,-    markOutboxSentBatch,-    markOutboxFailedTx,-    markOutboxSkippedTx,-    lookupOutbox,-    listOutbox,-    countOutboxBacklog,-    garbageCollectSent,-)-where--import Contravariant.Extras (contrazip2, contrazip3, contrazip5)-import Data.ByteString (ByteString)-import Data.Functor.Contravariant ((>$<))-import Data.Time.Clock (NominalDiffTime, addUTCTime)-import Data.UUID (UUID)-import Effectful (Eff, (:>))-import Hasql.Decoders qualified as D-import Hasql.Encoders qualified as E-import Hasql.Statement (Statement, preparable)-import Keiro.Integration.Event (-    IntegrationEvent (..),-    SchemaReference (..),-    TraceContext (..),-    contentTypeText,-    parseContentType,- )-import Keiro.Outbox.Types-import Keiro.Prelude-import Kiroku.Store.Effect (Store)-import Kiroku.Store.Transaction (runTransaction)-import Kiroku.Store.Types (EventId (..), GlobalPosition (..))-import "hasql-transaction" Hasql.Transaction qualified as Tx--{- | Enqueue one integration event inside an existing transaction.--The @(source, message_id)@ unique constraint catches duplicate retries-from a saga/process-manager. Callers that mint a fresh @messageId@ per-attempt should also mint a fresh @outboxId@; callers that want-idempotent retries should reuse both.--The row's @created_at@ value is the PostgreSQL transaction-start time. The-per-key and per-source publisher policies therefore provide only best-effort-ordering when concurrent transactions enqueue the same key/source and commit-in the opposite order. Serialize those transactions when strict order matters;-the canonical producer subscription already does so.--}-enqueueOutboxTx :: OutboxMessage -> Tx.Transaction ()-enqueueOutboxTx message =-    Tx.statement (toEncodedRow message) enqueueOutboxStmt---- | Read a single outbox row by id. Used by tests and inspection tooling.-lookupOutbox :: (Store :> es) => OutboxId -> Eff es (Maybe OutboxRow)-lookupOutbox outboxId =-    runTransaction $-        Tx.statement (unOutboxId outboxId) lookupOutboxStmt--{- | List outbox rows for a source, ordered by @created_at@. Used by tests;-not intended for application traffic.--}-listOutbox :: (Store :> es) => Text -> Eff es [OutboxRow]-listOutbox source =-    runTransaction $-        Tx.statement source listOutboxStmt--{- | Count outbox rows awaiting publish (backlog gauge source).--Backlog = rows in a claimable, non-terminal state. Mirrors the claim-query's @status IN ('pending','failed')@ predicate so the gauge measures-exactly the rows a publisher still has to drain (rows held mid-pass in-@publishing@, and the terminal @sent@/@dead@ rows, are excluded).--}-countOutboxBacklog :: (Store :> es) => Eff es Int-countOutboxBacklog =-    runTransaction (Tx.statement () countBacklogStmt)--{- | Delete @sent@ rows whose @published_at@ is older than @keepFor@ before-@now@.--Returns the number of rows deleted. @dead@ rows are never deleted: they are-operator action items proving an event was not published. The retention window-only bounds how long successful publish history remains queryable; consumer-dedupe lives in the inbox, not here.--}-garbageCollectSent ::-    (Store :> es) =>-    NominalDiffTime ->-    UTCTime ->-    Eff es Int-garbageCollectSent keepFor now = do-    let cutoff = addUTCTime (negate keepFor) now-    result <--        runTransaction $-            Tx.statement cutoff gcSentStmt-    pure (fromIntegral result)--{- | Claim up to @limit@ rows ready for publish.--Rows in @pending@ or @failed@ status whose @next_attempt_at@ has passed-become candidates. The selection is filtered by 'OrderingPolicy':--* 'PerKeyHeadOfLine' — a row is claimed only if every earlier-  non-terminal row with the same @(source, message_key)@ is also claimed-  by the same statement. Rows with @message_key IS NULL@ bypass the-  per-key check.-* 'PerSourceStream' — a row is claimed only if every earlier-  non-terminal row in the same @source@ is also claimed by the same-  statement, regardless of key.-* 'StopTheLine' — same as 'PerKeyHeadOfLine' at claim time; the worker-  halts on the first failure (decided at the worker level).-* 'BestEffort' — no head-of-line predicate.--The returned list preserves @(created_at, outbox_id)@ order. Per-key and-per-source subsequences are therefore gapless ordered runs. The @LIMIT@-applies to the locked candidate set before the post-filter; under-concurrent claimers or a limit cut through the middle of a run, a pass-can return fewer than @limit@ rows even when more rows are ready.--Claimed rows are transitioned to @publishing@ and have their-@attempt_count@ incremented atomically.--}-claimOutboxBatch ::-    (Store :> es) =>-    OrderingPolicy ->-    Int ->-    UTCTime ->-    Eff es [OutboxRow]-claimOutboxBatch policy limit now =-    runTransaction $-        Tx.statement (fromIntegral limit, now) (claimStmt policy)--{- | Reclaim rows stranded in @publishing@ longer than @olderThan@.--Rows whose claim already consumed the attempt budget are dead-lettered; the-rest return to @failed@ so the regular claim query can retry them. Returns-@(requeued, deadLettered)@.--}-requeueStuckOutbox ::-    (Store :> es) =>-    Int ->-    NominalDiffTime ->-    UTCTime ->-    Eff es (Int, Int)-requeueStuckOutbox maxAttempts olderThan now =-    runTransaction $ do-        let cutoff = addUTCTime (negate olderThan) now-        dead <- Tx.statement (cutoff, fromIntegral maxAttempts, now) deadLetterStuckStmt-        requeued <- Tx.statement (cutoff, fromIntegral maxAttempts, now) requeueStuckStmt-        pure (fromIntegral requeued, fromIntegral dead)--{- | Mark a row as successfully published. Sets @published_at@ and clears-@last_error@. Returns 'False' if the row left @publishing@ before the mark,-for example because a stale-row sweeper or operator changed it while the-transport publish was in flight. The publish may still have happened; callers-must treat this as at-least-once delivery.--}-markOutboxSent :: (Store :> es) => OutboxId -> UTCTime -> Eff es Bool-markOutboxSent outboxId now =-    runTransaction $-        Tx.statement (unOutboxId outboxId, now) markSentStmt--{- | Mark many rows as successfully published in one statement.--Only rows still in @publishing@ transition. Returns how many rows changed;-callers treat a shortfall as benign because delivery is already at-least-once.--}-markOutboxSentBatch :: (Store :> es) => [OutboxId] -> UTCTime -> Eff es Int-markOutboxSentBatch [] _ = pure 0-markOutboxSentBatch outboxIds now =-    fromIntegral-        <$> runTransaction-            ( Tx.statement-                (fmap unOutboxId outboxIds, now)-                markSentBatchStmt-            )--{- | Mark a row as failed and decide whether it is retryable or dead.--Reads the current @attempt_count@; if it is greater than or equal to-@maxAttempts@, transitions to 'OutboxDead'. Otherwise transitions to-'OutboxFailed' and sets @next_attempt_at = now + delay@. Returns the-resulting status so the worker can update its summary counters.--Runs inside the caller's transaction to keep "read attempt count → write-status" atomic with respect to other workers.--Only rows still in @publishing@ are updated (matching 'markSentBatchStmt'-and 'markSkippedStmt'): if the row outlived 'publishingTimeout' and-'outboxMaintenancePass' already requeued it — possibly handing it to-another worker — a late failure mark from the original worker must not-flip the re-claimed row mid-publish.--}-markOutboxFailedTx ::-    OutboxId ->-    Text ->-    Int ->-    NominalDiffTime ->-    UTCTime ->-    Tx.Transaction OutboxStatus-markOutboxFailedTx outboxId errMsg maxAttempts delay now = do-    currentAttempt <- Tx.statement (unOutboxId outboxId) readAttemptCountStmt-    let attempt = fromMaybe 0 currentAttempt-        shouldDie = attempt >= maxAttempts-        nextStatus = if shouldDie then OutboxDead else OutboxFailed-        nextAttempt = addUTCTime delay now-    Tx.statement-        (unOutboxId outboxId, statusText nextStatus, errMsg, nextAttempt, now)-        markFailedStmt-    pure nextStatus--{- | Return a claimed row to @failed@ without consuming an attempt.--Used for rows skipped because an earlier row in the same ordered group failed-inside the same publish batch.--}-markOutboxSkippedTx :: OutboxId -> Text -> UTCTime -> Tx.Transaction ()-markOutboxSkippedTx outboxId errMsg now =-    Tx.statement (unOutboxId outboxId, errMsg, now) markSkippedStmt---- ------------------------------------------------------------------------------ Encoder support--- -----------------------------------------------------------------------------{- | Flattened row used as the encoder input. Field order is locked to-the INSERT statement; the encoder threads each field through a separate-'E.Params' fragment joined by 'mconcat'.--}-data EncodedRow = EncodedRow-    { outboxId :: !UUID-    , messageId :: !Text-    , source :: !Text-    , destination :: !Text-    , messageKey :: !(Maybe Text)-    , eventType :: !Text-    , schemaVersion :: !Int64-    , contentType :: !Text-    , schemaRegistry :: !(Maybe Text)-    , schemaSubject :: !(Maybe Text)-    , schemaVersionRef :: !(Maybe Int64)-    , schemaId :: !(Maybe Int64)-    , schemaFingerprint :: !(Maybe Text)-    , sourceEventId :: !(Maybe UUID)-    , sourceGlobalPosition :: !(Maybe Int64)-    , causationId :: !(Maybe UUID)-    , correlationId :: !(Maybe UUID)-    , traceparent :: !(Maybe Text)-    , tracestate :: !(Maybe Text)-    , payloadBytes :: !ByteString-    , attributes :: !(Maybe Value)-    , occurredAt :: !UTCTime-    }-    deriving stock (Generic)--toEncodedRow :: OutboxMessage -> EncodedRow-toEncodedRow message =-    let event = message ^. #event-        mref = event ^. #schemaReference-        mtrace = event ^. #traceContext-     in EncodedRow-            { outboxId = unOutboxId (message ^. #outboxId)-            , messageId = event ^. #messageId-            , source = event ^. #source-            , destination = event ^. #destination-            , messageKey = event ^. #key-            , eventType = event ^. #eventType-            , schemaVersion = fromIntegral (event ^. #schemaVersion)-            , contentType = contentTypeText (event ^. #contentType)-            , schemaRegistry = mref >>= (^. #registry)-            , schemaSubject = mref >>= (^. #subject)-            , schemaVersionRef = fmap fromIntegral (mref >>= (^. #version))-            , schemaId = mref >>= (^. #schemaId)-            , schemaFingerprint = mref >>= (^. #fingerprint)-            , sourceEventId = fmap unEventId (event ^. #sourceEventId)-            , sourceGlobalPosition = fmap unGlobalPosition (event ^. #sourceGlobalPosition)-            , causationId = fmap unEventId (event ^. #causationId)-            , correlationId = fmap unEventId (event ^. #correlationId)-            , traceparent = fmap (^. #traceparent) mtrace-            , tracestate = mtrace >>= (^. #tracestate)-            , payloadBytes = event ^. #payloadBytes-            , attributes = event ^. #attributes-            , occurredAt = event ^. #occurredAt-            }--unEventId :: EventId -> UUID-unEventId (EventId u) = u--unGlobalPosition :: GlobalPosition -> Int64-unGlobalPosition (GlobalPosition i) = i--encodedRowEncoder :: E.Params EncodedRow-encodedRowEncoder =-    mconcat-        [ view #outboxId >$< E.param (E.nonNullable E.uuid)-        , view #messageId >$< E.param (E.nonNullable E.text)-        , view #source >$< E.param (E.nonNullable E.text)-        , view #destination >$< E.param (E.nonNullable E.text)-        , view #messageKey >$< E.param (E.nullable E.text)-        , view #eventType >$< E.param (E.nonNullable E.text)-        , view #schemaVersion >$< E.param (E.nonNullable E.int8)-        , view #contentType >$< E.param (E.nonNullable E.text)-        , view #schemaRegistry >$< E.param (E.nullable E.text)-        , view #schemaSubject >$< E.param (E.nullable E.text)-        , view #schemaVersionRef >$< E.param (E.nullable E.int8)-        , view #schemaId >$< E.param (E.nullable E.int8)-        , view #schemaFingerprint >$< E.param (E.nullable E.text)-        , view #sourceEventId >$< E.param (E.nullable E.uuid)-        , view #sourceGlobalPosition >$< E.param (E.nullable E.int8)-        , view #causationId >$< E.param (E.nullable E.uuid)-        , view #correlationId >$< E.param (E.nullable E.uuid)-        , view #traceparent >$< E.param (E.nullable E.text)-        , view #tracestate >$< E.param (E.nullable E.text)-        , view #payloadBytes >$< E.param (E.nonNullable E.bytea)-        , view #attributes >$< E.param (E.nullable E.jsonb)-        , view #occurredAt >$< E.param (E.nonNullable E.timestamptz)-        ]---- ------------------------------------------------------------------------------ Statements--- -----------------------------------------------------------------------------enqueueOutboxStmt :: Statement EncodedRow ()-enqueueOutboxStmt =-    preparable-        """-        INSERT INTO keiro.keiro_outbox-          ( outbox_id-          , message_id-          , source-          , destination-          , message_key-          , event_type-          , schema_version-          , content_type-          , schema_registry-          , schema_subject-          , schema_version_ref-          , schema_id-          , schema_fingerprint-          , source_event_id-          , source_global_position-          , causation_id-          , correlation_id-          , traceparent-          , tracestate-          , payload_bytes-          , attributes-          , occurred_at-          )-        VALUES-          ($1, $2, $3, $4, $5, $6, $7, $8, $9, $10, $11, $12, $13, $14, $15, $16, $17, $18, $19, $20, $21, $22)-        ON CONFLICT (source, message_id) DO NOTHING-        """-        encodedRowEncoder-        D.noResult--claimStmt :: OrderingPolicy -> Statement (Int64, UTCTime) [OutboxRow]-claimStmt policy =-    preparable-        (claimSql (policyPredicates policy))-        ( contrazip2-            (E.param (E.nonNullable E.int8))-            (E.param (E.nonNullable E.timestamptz))-        )-        (D.rowList claimResultDecoder)--data PolicyPredicates = PolicyPredicates-    { preFilter :: !Text-    , postFilter :: !Text-    }-    deriving stock (Generic)--policyPredicates :: OrderingPolicy -> PolicyPredicates-policyPredicates = \case-    PerKeyHeadOfLine -> perKeyPredicates-    PerSourceStream -> perSourcePredicates-    StopTheLine -> perKeyPredicates-    BestEffort -> PolicyPredicates{preFilter = "TRUE", postFilter = "TRUE"}--perKeyPredicates :: PolicyPredicates-perKeyPredicates =-    PolicyPredicates-        { preFilter =-            """-            ( r.message_key IS NULL OR NOT EXISTS (-                SELECT 1 FROM keiro.keiro_outbox earlier-                WHERE earlier.source = r.source-                  AND earlier.message_key = r.message_key-                  AND (earlier.created_at, earlier.outbox_id) < (r.created_at, r.outbox_id)-                  AND earlier.status NOT IN ('sent', 'dead')-                  AND NOT (earlier.status IN ('pending', 'failed') AND earlier.next_attempt_at <= $2) ) )-            """-        , postFilter =-            """-            ( c.message_key IS NULL OR NOT EXISTS (-                SELECT 1 FROM keiro.keiro_outbox earlier-                WHERE earlier.source = c.source-                  AND earlier.message_key = c.message_key-                  AND (earlier.created_at, earlier.outbox_id) < (c.created_at, c.outbox_id)-                  AND earlier.status NOT IN ('sent', 'dead')-                  AND NOT EXISTS (-                    SELECT 1 FROM candidate c2-                    WHERE c2.outbox_id = earlier.outbox_id ) ) )-            """-        }--perSourcePredicates :: PolicyPredicates-perSourcePredicates =-    PolicyPredicates-        { preFilter =-            """-            NOT EXISTS (-              SELECT 1 FROM keiro.keiro_outbox earlier-              WHERE earlier.source = r.source-                AND (earlier.created_at, earlier.outbox_id) < (r.created_at, r.outbox_id)-                AND earlier.status NOT IN ('sent', 'dead')-                AND NOT (earlier.status IN ('pending', 'failed') AND earlier.next_attempt_at <= $2) )-            """-        , postFilter =-            """-            NOT EXISTS (-              SELECT 1 FROM keiro.keiro_outbox earlier-              WHERE earlier.source = c.source-                AND (earlier.created_at, earlier.outbox_id) < (c.created_at, c.outbox_id)-                AND earlier.status NOT IN ('sent', 'dead')-                AND NOT EXISTS (-                  SELECT 1 FROM candidate c2-                  WHERE c2.outbox_id = earlier.outbox_id ) )-            """-        }--claimSql :: PolicyPredicates -> Text-claimSql PolicyPredicates{preFilter, postFilter} =-    """-    WITH candidate AS (-      SELECT r.outbox_id, r.source, r.message_key, r.created_at-      FROM keiro.keiro_outbox r-      WHERE r.status IN ('pending', 'failed')-        AND r.next_attempt_at <= $2-        AND (-    """-        <> preFilter-        <> """--           )-             ORDER BY r.created_at, r.outbox_id-             LIMIT $1-             FOR UPDATE SKIP LOCKED-           ),-           ready AS (-           SELECT c.outbox_id, c.created_at AS claim_created_at-           FROM candidate c-           WHERE (-           """-        <> postFilter-        <> """--           )-           ),-           updated AS (-           UPDATE keiro.keiro_outbox kt-           SET status = 'publishing', attempt_count = kt.attempt_count + 1, updated_at = $2-           FROM ready-           WHERE kt.outbox_id = ready.outbox_id-           RETURNING ready.claim_created_at,--           """-        <> rowColumns-        <> """--           )-           SELECT--           """-        <> unqualifiedRowColumns-        <> """--           FROM updated-           ORDER BY claim_created_at, outbox_id-           """--rowColumns :: Text-rowColumns =-    """-    kt.outbox_id, kt.message_id, kt.source, kt.destination, kt.message_key,-    kt.event_type, kt.schema_version, kt.content_type, kt.schema_registry,-    kt.schema_subject, kt.schema_version_ref, kt.schema_id, kt.schema_fingerprint,-    kt.source_event_id, kt.source_global_position, kt.causation_id,-    kt.correlation_id, kt.traceparent, kt.tracestate, kt.payload_bytes,-    kt.attributes, kt.occurred_at, kt.status, kt.attempt_count,-    kt.next_attempt_at, kt.last_error, kt.published_at, kt.created_at,-    kt.updated_at-    """--unqualifiedRowColumns :: Text-unqualifiedRowColumns =-    """-    outbox_id, message_id, source, destination, message_key,-    event_type, schema_version, content_type, schema_registry,-    schema_subject, schema_version_ref, schema_id, schema_fingerprint,-    source_event_id, source_global_position, causation_id,-    correlation_id, traceparent, tracestate, payload_bytes,-    attributes, occurred_at, status, attempt_count,-    next_attempt_at, last_error, published_at, created_at,-    updated_at-    """--claimResultDecoder :: D.Row OutboxRow-claimResultDecoder = outboxRowDecoder--countBacklogStmt :: Statement () Int-countBacklogStmt =-    preparable-        "SELECT COUNT(*)::bigint FROM keiro.keiro_outbox WHERE status IN ('pending', 'failed')"-        E.noParams-        (fmap fromIntegral (D.singleRow (D.column (D.nonNullable D.int8))))--gcSentStmt :: Statement UTCTime Int64-gcSentStmt =-    preparable-        """-        WITH deleted AS (-          DELETE FROM keiro.keiro_outbox-          WHERE status = 'sent' AND published_at < $1-          RETURNING 1-        )-        SELECT COALESCE(COUNT(*), 0)::bigint FROM deleted-        """-        (E.param (E.nonNullable E.timestamptz))-        (D.singleRow (D.column (D.nonNullable D.int8)))--readAttemptCountStmt :: Statement UUID (Maybe Int)-readAttemptCountStmt =-    preparable-        "SELECT attempt_count FROM keiro.keiro_outbox WHERE outbox_id = $1"-        (E.param (E.nonNullable E.uuid))-        (D.rowMaybe (fromIntegral <$> D.column (D.nonNullable D.int8)))--deadLetterStuckStmt :: Statement (UTCTime, Int64, UTCTime) Int64-deadLetterStuckStmt =-    preparable-        """-        UPDATE keiro.keiro_outbox-        SET status = 'dead',-            last_error = COALESCE(last_error, 'reclaimed: publisher crashed mid-publish'),-            updated_at = $3-        WHERE status = 'publishing'-          AND updated_at <= $1-          AND attempt_count >= $2-        """-        ( contrazip3-            (E.param (E.nonNullable E.timestamptz))-            (E.param (E.nonNullable E.int8))-            (E.param (E.nonNullable E.timestamptz))-        )-        D.rowsAffected--requeueStuckStmt :: Statement (UTCTime, Int64, UTCTime) Int64-requeueStuckStmt =-    preparable-        """-        UPDATE keiro.keiro_outbox-        SET status = 'failed',-            updated_at = $3-        WHERE status = 'publishing'-          AND updated_at <= $1-          AND attempt_count < $2-        """-        ( contrazip3-            (E.param (E.nonNullable E.timestamptz))-            (E.param (E.nonNullable E.int8))-            (E.param (E.nonNullable E.timestamptz))-        )-        D.rowsAffected--markSentStmt :: Statement (UUID, UTCTime) Bool-markSentStmt =-    preparable-        """-        UPDATE keiro.keiro_outbox-        SET status = 'sent',-            published_at = $2,-            last_error = NULL,-            updated_at = $2-        WHERE outbox_id = $1-          AND status = 'publishing'-        """-        ( contrazip2-            (E.param (E.nonNullable E.uuid))-            (E.param (E.nonNullable E.timestamptz))-        )-        ((> 0) <$> D.rowsAffected)--markSentBatchStmt :: Statement ([UUID], UTCTime) Int64-markSentBatchStmt =-    preparable-        """-        UPDATE keiro.keiro_outbox-        SET status = 'sent',-            published_at = $2,-            last_error = NULL,-            updated_at = $2-        WHERE outbox_id = ANY($1)-          AND status = 'publishing'-        """-        ( contrazip2-            (E.param (E.nonNullable (E.foldableArray (E.nonNullable E.uuid))))-            (E.param (E.nonNullable E.timestamptz))-        )-        D.rowsAffected--markFailedStmt :: Statement (UUID, Text, Text, UTCTime, UTCTime) ()-markFailedStmt =-    preparable-        """-        UPDATE keiro.keiro_outbox-        SET status = $2,-            last_error = $3,-            next_attempt_at = $4,-            updated_at = $5-        WHERE outbox_id = $1-          AND status = 'publishing'-        """-        ( contrazip5-            (E.param (E.nonNullable E.uuid))-            (E.param (E.nonNullable E.text))-            (E.param (E.nonNullable E.text))-            (E.param (E.nonNullable E.timestamptz))-            (E.param (E.nonNullable E.timestamptz))-        )-        D.noResult--markSkippedStmt :: Statement (UUID, Text, UTCTime) ()-markSkippedStmt =-    preparable-        """-        UPDATE keiro.keiro_outbox-        SET status = 'failed',-            attempt_count = GREATEST(attempt_count - 1, 0),-            last_error = $2,-            next_attempt_at = $3,-            updated_at = $3-        WHERE outbox_id = $1-          AND status = 'publishing'-        """-        ( contrazip3-            (E.param (E.nonNullable E.uuid))-            (E.param (E.nonNullable E.text))-            (E.param (E.nonNullable E.timestamptz))-        )-        D.noResult--lookupOutboxStmt :: Statement UUID (Maybe OutboxRow)-lookupOutboxStmt =-    preparable-        (selectAllSql <> " WHERE outbox_id = $1")-        (E.param (E.nonNullable E.uuid))-        (D.rowMaybe outboxRowDecoder)--listOutboxStmt :: Statement Text [OutboxRow]-listOutboxStmt =-    preparable-        (selectAllSql <> " WHERE source = $1 ORDER BY created_at, outbox_id")-        (E.param (E.nonNullable E.text))-        (D.rowList outboxRowDecoder)--selectAllSql :: Text-selectAllSql =-    """-    SELECT outbox_id, message_id, source, destination, message_key, event_type,-           schema_version, content_type, schema_registry, schema_subject,-           schema_version_ref, schema_id, schema_fingerprint, source_event_id,-           source_global_position, causation_id, correlation_id, traceparent,-           tracestate, payload_bytes, attributes, occurred_at, status,-           attempt_count, next_attempt_at, last_error, published_at, created_at,-           updated_at-    FROM keiro.keiro_outbox-    """--outboxRowDecoder :: D.Row OutboxRow-outboxRowDecoder = fmap assembleRow rawRowDecoder--data RawRow = RawRow-    { outboxId :: !OutboxId-    , messageId :: !Text-    , source :: !Text-    , destination :: !Text-    , key :: !(Maybe Text)-    , eventType :: !Text-    , schemaVersion :: !Int-    , contentType :: !Text-    , schemaRegistry :: !(Maybe Text)-    , schemaSubject :: !(Maybe Text)-    , schemaVersionRef :: !(Maybe Int)-    , schemaId :: !(Maybe Int64)-    , schemaFingerprint :: !(Maybe Text)-    , sourceEventId :: !(Maybe EventId)-    , sourceGlobalPosition :: !(Maybe GlobalPosition)-    , causationId :: !(Maybe EventId)-    , correlationId :: !(Maybe EventId)-    , traceparent :: !(Maybe Text)-    , tracestate :: !(Maybe Text)-    , payloadBytes :: !ByteString-    , attributes :: !(Maybe Value)-    , occurredAt :: !UTCTime-    , status :: !OutboxStatus-    , attemptCount :: !Int-    , nextAttemptAt :: !UTCTime-    , lastError :: !(Maybe Text)-    , publishedAt :: !(Maybe UTCTime)-    , createdAt :: !UTCTime-    , updatedAt :: !UTCTime-    }-    deriving stock (Generic)--rawRowDecoder :: D.Row RawRow-rawRowDecoder =-    RawRow-        <$> (OutboxId <$> D.column (D.nonNullable D.uuid))-        <*> D.column (D.nonNullable D.text)-        <*> D.column (D.nonNullable D.text)-        <*> D.column (D.nonNullable D.text)-        <*> D.column (D.nullable D.text)-        <*> D.column (D.nonNullable D.text)-        <*> (fromIntegral <$> D.column (D.nonNullable D.int8))-        <*> D.column (D.nonNullable D.text)-        <*> D.column (D.nullable D.text)-        <*> D.column (D.nullable D.text)-        <*> (fmap fromIntegral <$> D.column (D.nullable D.int8))-        <*> D.column (D.nullable D.int8)-        <*> D.column (D.nullable D.text)-        <*> (fmap EventId <$> D.column (D.nullable D.uuid))-        <*> (fmap GlobalPosition <$> D.column (D.nullable D.int8))-        <*> (fmap EventId <$> D.column (D.nullable D.uuid))-        <*> (fmap EventId <$> D.column (D.nullable D.uuid))-        <*> D.column (D.nullable D.text)-        <*> D.column (D.nullable D.text)-        <*> D.column (D.nonNullable D.bytea)-        <*> D.column (D.nullable D.jsonb)-        <*> D.column (D.nonNullable D.timestamptz)-        <*> D.column (D.nonNullable (D.refine parseStatus D.text))-        <*> (fromIntegral <$> D.column (D.nonNullable D.int8))-        <*> D.column (D.nonNullable D.timestamptz)-        <*> D.column (D.nullable D.text)-        <*> D.column (D.nullable D.timestamptz)-        <*> D.column (D.nonNullable D.timestamptz)-        <*> D.column (D.nonNullable D.timestamptz)--assembleRow :: RawRow -> OutboxRow-assembleRow raw =-    let traceContext = case raw ^. #traceparent of-            Nothing -> Nothing-            Just tp -> Just (TraceContext tp (raw ^. #tracestate))-        schemaReference =-            case ( raw ^. #schemaRegistry-                 , raw ^. #schemaSubject-                 , raw ^. #schemaVersionRef-                 , raw ^. #schemaId-                 , raw ^. #schemaFingerprint-                 ) of-                (Nothing, Nothing, Nothing, Nothing, Nothing) -> Nothing-                _ ->-                    Just-                        ( SchemaReference-                            (raw ^. #schemaRegistry)-                            (raw ^. #schemaSubject)-                            (raw ^. #schemaVersionRef)-                            (raw ^. #schemaId)-                            (raw ^. #schemaFingerprint)-                        )-        event =-            IntegrationEvent-                { messageId = raw ^. #messageId-                , source = raw ^. #source-                , destination = raw ^. #destination-                , key = raw ^. #key-                , eventType = raw ^. #eventType-                , schemaVersion = raw ^. #schemaVersion-                , contentType = parseContentType (raw ^. #contentType)-                , schemaReference-                , sourceEventId = raw ^. #sourceEventId-                , sourceGlobalPosition = raw ^. #sourceGlobalPosition-                , payloadBytes = raw ^. #payloadBytes-                , occurredAt = raw ^. #occurredAt-                , causationId = raw ^. #causationId-                , correlationId = raw ^. #correlationId-                , traceContext-                , attributes = raw ^. #attributes-                }-     in OutboxRow-            { outboxId = raw ^. #outboxId-            , event-            , status = raw ^. #status-            , attemptCount = raw ^. #attemptCount-            , nextAttemptAt = raw ^. #nextAttemptAt-            , lastError = raw ^. #lastError-            , publishedAt = raw ^. #publishedAt-            , createdAt = raw ^. #createdAt-            , updatedAt = raw ^. #updatedAt-            }+-- | Hasql-level storage for the durable integration-event outbox.+--+-- This module owns the SQL surface that publishers call into. Higher-level+-- helpers ('Keiro.Outbox') and transport adapters+-- ('Keiro.Outbox.Kafka') consume these primitives.+module Keiro.Outbox.Schema+  ( enqueueOutboxTx,+    claimOutboxBatch,+    requeueStuckOutbox,+    markOutboxSent,+    markOutboxSentBatch,+    markOutboxFailedTx,+    markOutboxSkippedTx,+    lookupOutbox,+    listOutbox,+    countOutboxBacklog,+    garbageCollectSent,+  )+where++import Contravariant.Extras (contrazip2, contrazip3, contrazip5)+import Data.ByteString (ByteString)+import Data.Functor.Contravariant ((>$<))+import Data.Time.Clock (NominalDiffTime, addUTCTime)+import Data.UUID (UUID)+import Effectful (Eff, (:>))+import Hasql.Decoders qualified as D+import Hasql.Encoders qualified as E+import Hasql.Statement (Statement, preparable)+import Keiro.Integration.Event+  ( IntegrationEvent (..),+    SchemaReference (..),+    TraceContext (..),+    contentTypeText,+    parseContentType,+  )+import Keiro.Outbox.Types+import Keiro.Prelude+import Kiroku.Store.Effect (Store)+import Kiroku.Store.Transaction (runTransaction)+import Kiroku.Store.Types (EventId (..), GlobalPosition (..))+import "hasql-transaction" Hasql.Transaction qualified as Tx++-- | Enqueue one integration event inside an existing transaction.+--+-- The @(source, message_id)@ unique constraint catches duplicate retries+-- from a saga/process-manager. Callers that mint a fresh @messageId@ per+-- attempt should also mint a fresh @outboxId@; callers that want+-- idempotent retries should reuse both.+--+-- The row's @created_at@ value is the PostgreSQL transaction-start time. The+-- per-key and per-source publisher policies therefore provide only best-effort+-- ordering when concurrent transactions enqueue the same key/source and commit+-- in the opposite order. Serialize those transactions when strict order matters;+-- the canonical producer subscription already does so.+enqueueOutboxTx :: OutboxMessage -> Tx.Transaction ()+enqueueOutboxTx message =+  Tx.statement (toEncodedRow message) enqueueOutboxStmt++-- | Read a single outbox row by id. Used by tests and inspection tooling.+lookupOutbox :: (Store :> es) => OutboxId -> Eff es (Maybe OutboxRow)+lookupOutbox outboxId =+  runTransaction $+    Tx.statement (unOutboxId outboxId) lookupOutboxStmt++-- | List outbox rows for a source, ordered by @created_at@. Used by tests;+-- not intended for application traffic.+listOutbox :: (Store :> es) => Text -> Eff es [OutboxRow]+listOutbox source =+  runTransaction $+    Tx.statement source listOutboxStmt++-- | Count outbox rows awaiting publish (backlog gauge source).+--+-- Backlog = rows in a claimable, non-terminal state. Mirrors the claim+-- query's @status IN ('pending','failed')@ predicate so the gauge measures+-- exactly the rows a publisher still has to drain (rows held mid-pass in+-- @publishing@, and the terminal @sent@/@dead@ rows, are excluded).+countOutboxBacklog :: (Store :> es) => Eff es Int+countOutboxBacklog =+  runTransaction (Tx.statement () countBacklogStmt)++-- | Delete @sent@ rows whose @published_at@ is older than @keepFor@ before+-- @now@.+--+-- Returns the number of rows deleted. @dead@ rows are never deleted: they are+-- operator action items proving an event was not published. The retention window+-- only bounds how long successful publish history remains queryable; consumer+-- dedupe lives in the inbox, not here.+garbageCollectSent ::+  (Store :> es) =>+  NominalDiffTime ->+  UTCTime ->+  Eff es Int+garbageCollectSent keepFor now = do+  let cutoff = addUTCTime (negate keepFor) now+  result <-+    runTransaction $+      Tx.statement cutoff gcSentStmt+  pure (fromIntegral result)++-- | Claim up to @limit@ rows ready for publish.+--+-- Rows in @pending@ or @failed@ status whose @next_attempt_at@ has passed+-- become candidates. The selection is filtered by 'OrderingPolicy':+--+-- * 'PerKeyHeadOfLine' — a row is claimed only if every earlier+--   non-terminal row with the same @(source, message_key)@ is also claimed+--   by the same statement. Rows with @message_key IS NULL@ bypass the+--   per-key check.+-- * 'PerSourceStream' — a row is claimed only if every earlier+--   non-terminal row in the same @source@ is also claimed by the same+--   statement, regardless of key.+-- * 'StopTheLine' — same as 'PerKeyHeadOfLine' at claim time; the worker+--   halts on the first failure (decided at the worker level).+-- * 'BestEffort' — no head-of-line predicate.+--+-- The returned list preserves @(created_at, outbox_id)@ order. Per-key and+-- per-source subsequences are therefore gapless ordered runs. The @LIMIT@+-- applies to the locked candidate set before the post-filter; under+-- concurrent claimers or a limit cut through the middle of a run, a pass+-- can return fewer than @limit@ rows even when more rows are ready.+--+-- Claimed rows are transitioned to @publishing@ and have their+-- @attempt_count@ incremented atomically.+claimOutboxBatch ::+  (Store :> es) =>+  OrderingPolicy ->+  Int ->+  UTCTime ->+  Eff es [OutboxRow]+claimOutboxBatch policy limit now =+  runTransaction $+    Tx.statement (fromIntegral limit, now) (claimStmt policy)++-- | Reclaim rows stranded in @publishing@ longer than @olderThan@.+--+-- Rows whose claim already consumed the attempt budget are dead-lettered; the+-- rest return to @failed@ so the regular claim query can retry them. Returns+-- @(requeued, deadLettered)@.+requeueStuckOutbox ::+  (Store :> es) =>+  Int ->+  NominalDiffTime ->+  UTCTime ->+  Eff es (Int, Int)+requeueStuckOutbox maxAttempts olderThan now =+  runTransaction $ do+    let cutoff = addUTCTime (negate olderThan) now+    dead <- Tx.statement (cutoff, fromIntegral maxAttempts, now) deadLetterStuckStmt+    requeued <- Tx.statement (cutoff, fromIntegral maxAttempts, now) requeueStuckStmt+    pure (fromIntegral requeued, fromIntegral dead)++-- | Mark a row as successfully published. Sets @published_at@ and clears+-- @last_error@. Returns 'False' if the row left @publishing@ before the mark,+-- for example because a stale-row sweeper or operator changed it while the+-- transport publish was in flight. The publish may still have happened; callers+-- must treat this as at-least-once delivery.+markOutboxSent :: (Store :> es) => OutboxId -> UTCTime -> Eff es Bool+markOutboxSent outboxId now =+  runTransaction $+    Tx.statement (unOutboxId outboxId, now) markSentStmt++-- | Mark many rows as successfully published in one statement.+--+-- Only rows still in @publishing@ transition. Returns how many rows changed;+-- callers treat a shortfall as benign because delivery is already at-least-once.+markOutboxSentBatch :: (Store :> es) => [OutboxId] -> UTCTime -> Eff es Int+markOutboxSentBatch [] _ = pure 0+markOutboxSentBatch outboxIds now =+  fromIntegral+    <$> runTransaction+      ( Tx.statement+          (fmap unOutboxId outboxIds, now)+          markSentBatchStmt+      )++-- | Mark a row as failed and decide whether it is retryable or dead.+--+-- Reads the current @attempt_count@; if it is greater than or equal to+-- @maxAttempts@, transitions to 'OutboxDead'. Otherwise transitions to+-- 'OutboxFailed' and sets @next_attempt_at = now + delay@. Returns the+-- resulting status so the worker can update its summary counters.+--+-- Runs inside the caller's transaction to keep "read attempt count → write+-- status" atomic with respect to other workers.+--+-- Only rows still in @publishing@ are updated (matching 'markSentBatchStmt'+-- and 'markSkippedStmt'): if the row outlived 'publishingTimeout' and+-- 'outboxMaintenancePass' already requeued it — possibly handing it to+-- another worker — a late failure mark from the original worker must not+-- flip the re-claimed row mid-publish.+markOutboxFailedTx ::+  OutboxId ->+  Text ->+  Int ->+  NominalDiffTime ->+  UTCTime ->+  Tx.Transaction OutboxStatus+markOutboxFailedTx outboxId errMsg maxAttempts delay now = do+  currentAttempt <- Tx.statement (unOutboxId outboxId) readAttemptCountStmt+  let attempt = fromMaybe 0 currentAttempt+      shouldDie = attempt >= maxAttempts+      nextStatus = if shouldDie then OutboxDead else OutboxFailed+      nextAttempt = addUTCTime delay now+  Tx.statement+    (unOutboxId outboxId, statusText nextStatus, errMsg, nextAttempt, now)+    markFailedStmt+  pure nextStatus++-- | Return a claimed row to @failed@ without consuming an attempt.+--+-- Used for rows skipped because an earlier row in the same ordered group failed+-- inside the same publish batch.+markOutboxSkippedTx :: OutboxId -> Text -> UTCTime -> Tx.Transaction ()+markOutboxSkippedTx outboxId errMsg now =+  Tx.statement (unOutboxId outboxId, errMsg, now) markSkippedStmt++-- ---------------------------------------------------------------------------+-- Encoder support+-- ---------------------------------------------------------------------------++-- | Flattened row used as the encoder input. Field order is locked to+-- the INSERT statement; the encoder threads each field through a separate+-- 'E.Params' fragment joined by 'mconcat'.+data EncodedRow = EncodedRow+  { outboxId :: !UUID,+    messageId :: !Text,+    source :: !Text,+    destination :: !Text,+    messageKey :: !(Maybe Text),+    eventType :: !Text,+    schemaVersion :: !Int64,+    contentType :: !Text,+    schemaRegistry :: !(Maybe Text),+    schemaSubject :: !(Maybe Text),+    schemaVersionRef :: !(Maybe Int64),+    schemaId :: !(Maybe Int64),+    schemaFingerprint :: !(Maybe Text),+    sourceEventId :: !(Maybe UUID),+    sourceGlobalPosition :: !(Maybe Int64),+    causationId :: !(Maybe UUID),+    correlationId :: !(Maybe UUID),+    traceparent :: !(Maybe Text),+    tracestate :: !(Maybe Text),+    payloadBytes :: !ByteString,+    attributes :: !(Maybe Value),+    occurredAt :: !UTCTime+  }+  deriving stock (Generic)++toEncodedRow :: OutboxMessage -> EncodedRow+toEncodedRow message =+  let event = message ^. #event+      mref = event ^. #schemaReference+      mtrace = event ^. #traceContext+   in EncodedRow+        { outboxId = unOutboxId (message ^. #outboxId),+          messageId = event ^. #messageId,+          source = event ^. #source,+          destination = event ^. #destination,+          messageKey = event ^. #key,+          eventType = event ^. #eventType,+          schemaVersion = fromIntegral (event ^. #schemaVersion),+          contentType = contentTypeText (event ^. #contentType),+          schemaRegistry = mref >>= (^. #registry),+          schemaSubject = mref >>= (^. #subject),+          schemaVersionRef = fmap fromIntegral (mref >>= (^. #version)),+          schemaId = mref >>= (^. #schemaId),+          schemaFingerprint = mref >>= (^. #fingerprint),+          sourceEventId = fmap unEventId (event ^. #sourceEventId),+          sourceGlobalPosition = fmap unGlobalPosition (event ^. #sourceGlobalPosition),+          causationId = fmap unEventId (event ^. #causationId),+          correlationId = fmap unEventId (event ^. #correlationId),+          traceparent = fmap (^. #traceparent) mtrace,+          tracestate = mtrace >>= (^. #tracestate),+          payloadBytes = event ^. #payloadBytes,+          attributes = event ^. #attributes,+          occurredAt = event ^. #occurredAt+        }++unEventId :: EventId -> UUID+unEventId (EventId u) = u++unGlobalPosition :: GlobalPosition -> Int64+unGlobalPosition (GlobalPosition i) = i++encodedRowEncoder :: E.Params EncodedRow+encodedRowEncoder =+  mconcat+    [ view #outboxId >$< E.param (E.nonNullable E.uuid),+      view #messageId >$< E.param (E.nonNullable E.text),+      view #source >$< E.param (E.nonNullable E.text),+      view #destination >$< E.param (E.nonNullable E.text),+      view #messageKey >$< E.param (E.nullable E.text),+      view #eventType >$< E.param (E.nonNullable E.text),+      view #schemaVersion >$< E.param (E.nonNullable E.int8),+      view #contentType >$< E.param (E.nonNullable E.text),+      view #schemaRegistry >$< E.param (E.nullable E.text),+      view #schemaSubject >$< E.param (E.nullable E.text),+      view #schemaVersionRef >$< E.param (E.nullable E.int8),+      view #schemaId >$< E.param (E.nullable E.int8),+      view #schemaFingerprint >$< E.param (E.nullable E.text),+      view #sourceEventId >$< E.param (E.nullable E.uuid),+      view #sourceGlobalPosition >$< E.param (E.nullable E.int8),+      view #causationId >$< E.param (E.nullable E.uuid),+      view #correlationId >$< E.param (E.nullable E.uuid),+      view #traceparent >$< E.param (E.nullable E.text),+      view #tracestate >$< E.param (E.nullable E.text),+      view #payloadBytes >$< E.param (E.nonNullable E.bytea),+      view #attributes >$< E.param (E.nullable E.jsonb),+      view #occurredAt >$< E.param (E.nonNullable E.timestamptz)+    ]++-- ---------------------------------------------------------------------------+-- Statements+-- ---------------------------------------------------------------------------++enqueueOutboxStmt :: Statement EncodedRow ()+enqueueOutboxStmt =+  preparable+    """+    INSERT INTO keiro.keiro_outbox+      ( outbox_id+      , message_id+      , source+      , destination+      , message_key+      , event_type+      , schema_version+      , content_type+      , schema_registry+      , schema_subject+      , schema_version_ref+      , schema_id+      , schema_fingerprint+      , source_event_id+      , source_global_position+      , causation_id+      , correlation_id+      , traceparent+      , tracestate+      , payload_bytes+      , attributes+      , occurred_at+      )+    VALUES+      ($1, $2, $3, $4, $5, $6, $7, $8, $9, $10, $11, $12, $13, $14, $15, $16, $17, $18, $19, $20, $21, $22)+    ON CONFLICT (source, message_id) DO NOTHING+    """+    encodedRowEncoder+    D.noResult++claimStmt :: OrderingPolicy -> Statement (Int64, UTCTime) [OutboxRow]+claimStmt policy =+  preparable+    (claimSql (policyPredicates policy))+    ( contrazip2+        (E.param (E.nonNullable E.int8))+        (E.param (E.nonNullable E.timestamptz))+    )+    (D.rowList claimResultDecoder)++data PolicyPredicates = PolicyPredicates+  { preFilter :: !Text,+    postFilter :: !Text+  }+  deriving stock (Generic)++policyPredicates :: OrderingPolicy -> PolicyPredicates+policyPredicates = \case+  PerKeyHeadOfLine -> perKeyPredicates+  PerSourceStream -> perSourcePredicates+  StopTheLine -> perKeyPredicates+  BestEffort -> PolicyPredicates {preFilter = "TRUE", postFilter = "TRUE"}++perKeyPredicates :: PolicyPredicates+perKeyPredicates =+  PolicyPredicates+    { preFilter =+        """+        ( r.message_key IS NULL OR NOT EXISTS (+            SELECT 1 FROM keiro.keiro_outbox earlier+            WHERE earlier.source = r.source+              AND earlier.message_key = r.message_key+              AND (earlier.created_at, earlier.outbox_id) < (r.created_at, r.outbox_id)+              AND earlier.status NOT IN ('sent', 'dead')+              AND NOT (earlier.status IN ('pending', 'failed') AND earlier.next_attempt_at <= $2) ) )+        """,+      postFilter =+        """+        ( c.message_key IS NULL OR NOT EXISTS (+            SELECT 1 FROM keiro.keiro_outbox earlier+            WHERE earlier.source = c.source+              AND earlier.message_key = c.message_key+              AND (earlier.created_at, earlier.outbox_id) < (c.created_at, c.outbox_id)+              AND earlier.status NOT IN ('sent', 'dead')+              AND NOT EXISTS (+                SELECT 1 FROM candidate c2+                WHERE c2.outbox_id = earlier.outbox_id ) ) )+        """+    }++perSourcePredicates :: PolicyPredicates+perSourcePredicates =+  PolicyPredicates+    { preFilter =+        """+        NOT EXISTS (+          SELECT 1 FROM keiro.keiro_outbox earlier+          WHERE earlier.source = r.source+            AND (earlier.created_at, earlier.outbox_id) < (r.created_at, r.outbox_id)+            AND earlier.status NOT IN ('sent', 'dead')+            AND NOT (earlier.status IN ('pending', 'failed') AND earlier.next_attempt_at <= $2) )+        """,+      postFilter =+        """+        NOT EXISTS (+          SELECT 1 FROM keiro.keiro_outbox earlier+          WHERE earlier.source = c.source+            AND (earlier.created_at, earlier.outbox_id) < (c.created_at, c.outbox_id)+            AND earlier.status NOT IN ('sent', 'dead')+            AND NOT EXISTS (+              SELECT 1 FROM candidate c2+              WHERE c2.outbox_id = earlier.outbox_id ) )+        """+    }++claimSql :: PolicyPredicates -> Text+claimSql PolicyPredicates {preFilter, postFilter} =+  """+  WITH candidate AS (+    SELECT r.outbox_id, r.source, r.message_key, r.created_at+    FROM keiro.keiro_outbox r+    WHERE r.status IN ('pending', 'failed')+      AND r.next_attempt_at <= $2+      AND (+  """+    <> preFilter+    <> """++       )+         ORDER BY r.created_at, r.outbox_id+         LIMIT $1+         FOR UPDATE SKIP LOCKED+       ),+       ready AS (+       SELECT c.outbox_id, c.created_at AS claim_created_at+       FROM candidate c+       WHERE (+       """+    <> postFilter+    <> """++       )+       ),+       updated AS (+       UPDATE keiro.keiro_outbox kt+       SET status = 'publishing', attempt_count = kt.attempt_count + 1, updated_at = $2+       FROM ready+       WHERE kt.outbox_id = ready.outbox_id+       RETURNING ready.claim_created_at,++       """+    <> rowColumns+    <> """++       )+       SELECT++       """+    <> unqualifiedRowColumns+    <> """++       FROM updated+       ORDER BY claim_created_at, outbox_id+       """++rowColumns :: Text+rowColumns =+  """+  kt.outbox_id, kt.message_id, kt.source, kt.destination, kt.message_key,+  kt.event_type, kt.schema_version, kt.content_type, kt.schema_registry,+  kt.schema_subject, kt.schema_version_ref, kt.schema_id, kt.schema_fingerprint,+  kt.source_event_id, kt.source_global_position, kt.causation_id,+  kt.correlation_id, kt.traceparent, kt.tracestate, kt.payload_bytes,+  kt.attributes, kt.occurred_at, kt.status, kt.attempt_count,+  kt.next_attempt_at, kt.last_error, kt.published_at, kt.created_at,+  kt.updated_at+  """++unqualifiedRowColumns :: Text+unqualifiedRowColumns =+  """+  outbox_id, message_id, source, destination, message_key,+  event_type, schema_version, content_type, schema_registry,+  schema_subject, schema_version_ref, schema_id, schema_fingerprint,+  source_event_id, source_global_position, causation_id,+  correlation_id, traceparent, tracestate, payload_bytes,+  attributes, occurred_at, status, attempt_count,+  next_attempt_at, last_error, published_at, created_at,+  updated_at+  """++claimResultDecoder :: D.Row OutboxRow+claimResultDecoder = outboxRowDecoder++countBacklogStmt :: Statement () Int+countBacklogStmt =+  preparable+    "SELECT COUNT(*)::bigint FROM keiro.keiro_outbox WHERE status IN ('pending', 'failed')"+    E.noParams+    (fmap fromIntegral (D.singleRow (D.column (D.nonNullable D.int8))))++gcSentStmt :: Statement UTCTime Int64+gcSentStmt =+  preparable+    """+    WITH deleted AS (+      DELETE FROM keiro.keiro_outbox+      WHERE status = 'sent' AND published_at < $1+      RETURNING 1+    )+    SELECT COALESCE(COUNT(*), 0)::bigint FROM deleted+    """+    (E.param (E.nonNullable E.timestamptz))+    (D.singleRow (D.column (D.nonNullable D.int8)))++readAttemptCountStmt :: Statement UUID (Maybe Int)+readAttemptCountStmt =+  preparable+    "SELECT attempt_count FROM keiro.keiro_outbox WHERE outbox_id = $1"+    (E.param (E.nonNullable E.uuid))+    (D.rowMaybe (fromIntegral <$> D.column (D.nonNullable D.int8)))++deadLetterStuckStmt :: Statement (UTCTime, Int64, UTCTime) Int64+deadLetterStuckStmt =+  preparable+    """+    UPDATE keiro.keiro_outbox+    SET status = 'dead',+        last_error = COALESCE(last_error, 'reclaimed: publisher crashed mid-publish'),+        updated_at = $3+    WHERE status = 'publishing'+      AND updated_at <= $1+      AND attempt_count >= $2+    """+    ( contrazip3+        (E.param (E.nonNullable E.timestamptz))+        (E.param (E.nonNullable E.int8))+        (E.param (E.nonNullable E.timestamptz))+    )+    D.rowsAffected++requeueStuckStmt :: Statement (UTCTime, Int64, UTCTime) Int64+requeueStuckStmt =+  preparable+    """+    UPDATE keiro.keiro_outbox+    SET status = 'failed',+        updated_at = $3+    WHERE status = 'publishing'+      AND updated_at <= $1+      AND attempt_count < $2+    """+    ( contrazip3+        (E.param (E.nonNullable E.timestamptz))+        (E.param (E.nonNullable E.int8))+        (E.param (E.nonNullable E.timestamptz))+    )+    D.rowsAffected++markSentStmt :: Statement (UUID, UTCTime) Bool+markSentStmt =+  preparable+    """+    UPDATE keiro.keiro_outbox+    SET status = 'sent',+        published_at = $2,+        last_error = NULL,+        updated_at = $2+    WHERE outbox_id = $1+      AND status = 'publishing'+    """+    ( contrazip2+        (E.param (E.nonNullable E.uuid))+        (E.param (E.nonNullable E.timestamptz))+    )+    ((> 0) <$> D.rowsAffected)++markSentBatchStmt :: Statement ([UUID], UTCTime) Int64+markSentBatchStmt =+  preparable+    """+    UPDATE keiro.keiro_outbox+    SET status = 'sent',+        published_at = $2,+        last_error = NULL,+        updated_at = $2+    WHERE outbox_id = ANY($1)+      AND status = 'publishing'+    """+    ( contrazip2+        (E.param (E.nonNullable (E.foldableArray (E.nonNullable E.uuid))))+        (E.param (E.nonNullable E.timestamptz))+    )+    D.rowsAffected++markFailedStmt :: Statement (UUID, Text, Text, UTCTime, UTCTime) ()+markFailedStmt =+  preparable+    """+    UPDATE keiro.keiro_outbox+    SET status = $2,+        last_error = $3,+        next_attempt_at = $4,+        updated_at = $5+    WHERE outbox_id = $1+      AND status = 'publishing'+    """+    ( contrazip5+        (E.param (E.nonNullable E.uuid))+        (E.param (E.nonNullable E.text))+        (E.param (E.nonNullable E.text))+        (E.param (E.nonNullable E.timestamptz))+        (E.param (E.nonNullable E.timestamptz))+    )+    D.noResult++markSkippedStmt :: Statement (UUID, Text, UTCTime) ()+markSkippedStmt =+  preparable+    """+    UPDATE keiro.keiro_outbox+    SET status = 'failed',+        attempt_count = GREATEST(attempt_count - 1, 0),+        last_error = $2,+        next_attempt_at = $3,+        updated_at = $3+    WHERE outbox_id = $1+      AND status = 'publishing'+    """+    ( contrazip3+        (E.param (E.nonNullable E.uuid))+        (E.param (E.nonNullable E.text))+        (E.param (E.nonNullable E.timestamptz))+    )+    D.noResult++lookupOutboxStmt :: Statement UUID (Maybe OutboxRow)+lookupOutboxStmt =+  preparable+    (selectAllSql <> " WHERE outbox_id = $1")+    (E.param (E.nonNullable E.uuid))+    (D.rowMaybe outboxRowDecoder)++listOutboxStmt :: Statement Text [OutboxRow]+listOutboxStmt =+  preparable+    (selectAllSql <> " WHERE source = $1 ORDER BY created_at, outbox_id")+    (E.param (E.nonNullable E.text))+    (D.rowList outboxRowDecoder)++selectAllSql :: Text+selectAllSql =+  """+  SELECT outbox_id, message_id, source, destination, message_key, event_type,+         schema_version, content_type, schema_registry, schema_subject,+         schema_version_ref, schema_id, schema_fingerprint, source_event_id,+         source_global_position, causation_id, correlation_id, traceparent,+         tracestate, payload_bytes, attributes, occurred_at, status,+         attempt_count, next_attempt_at, last_error, published_at, created_at,+         updated_at+  FROM keiro.keiro_outbox+  """++outboxRowDecoder :: D.Row OutboxRow+outboxRowDecoder = fmap assembleRow rawRowDecoder++data RawRow = RawRow+  { outboxId :: !OutboxId,+    messageId :: !Text,+    source :: !Text,+    destination :: !Text,+    key :: !(Maybe Text),+    eventType :: !Text,+    schemaVersion :: !Int,+    contentType :: !Text,+    schemaRegistry :: !(Maybe Text),+    schemaSubject :: !(Maybe Text),+    schemaVersionRef :: !(Maybe Int),+    schemaId :: !(Maybe Int64),+    schemaFingerprint :: !(Maybe Text),+    sourceEventId :: !(Maybe EventId),+    sourceGlobalPosition :: !(Maybe GlobalPosition),+    causationId :: !(Maybe EventId),+    correlationId :: !(Maybe EventId),+    traceparent :: !(Maybe Text),+    tracestate :: !(Maybe Text),+    payloadBytes :: !ByteString,+    attributes :: !(Maybe Value),+    occurredAt :: !UTCTime,+    status :: !OutboxStatus,+    attemptCount :: !Int,+    nextAttemptAt :: !UTCTime,+    lastError :: !(Maybe Text),+    publishedAt :: !(Maybe UTCTime),+    createdAt :: !UTCTime,+    updatedAt :: !UTCTime+  }+  deriving stock (Generic)++rawRowDecoder :: D.Row RawRow+rawRowDecoder =+  RawRow+    <$> (OutboxId <$> D.column (D.nonNullable D.uuid))+    <*> D.column (D.nonNullable D.text)+    <*> D.column (D.nonNullable D.text)+    <*> D.column (D.nonNullable D.text)+    <*> D.column (D.nullable D.text)+    <*> D.column (D.nonNullable D.text)+    <*> (fromIntegral <$> D.column (D.nonNullable D.int8))+    <*> D.column (D.nonNullable D.text)+    <*> D.column (D.nullable D.text)+    <*> D.column (D.nullable D.text)+    <*> (fmap fromIntegral <$> D.column (D.nullable D.int8))+    <*> D.column (D.nullable D.int8)+    <*> D.column (D.nullable D.text)+    <*> (fmap EventId <$> D.column (D.nullable D.uuid))+    <*> (fmap GlobalPosition <$> D.column (D.nullable D.int8))+    <*> (fmap EventId <$> D.column (D.nullable D.uuid))+    <*> (fmap EventId <$> D.column (D.nullable D.uuid))+    <*> D.column (D.nullable D.text)+    <*> D.column (D.nullable D.text)+    <*> D.column (D.nonNullable D.bytea)+    <*> D.column (D.nullable D.jsonb)+    <*> D.column (D.nonNullable D.timestamptz)+    <*> D.column (D.nonNullable (D.refine parseStatus D.text))+    <*> (fromIntegral <$> D.column (D.nonNullable D.int8))+    <*> D.column (D.nonNullable D.timestamptz)+    <*> D.column (D.nullable D.text)+    <*> D.column (D.nullable D.timestamptz)+    <*> D.column (D.nonNullable D.timestamptz)+    <*> D.column (D.nonNullable D.timestamptz)++assembleRow :: RawRow -> OutboxRow+assembleRow raw =+  let traceContext = case raw ^. #traceparent of+        Nothing -> Nothing+        Just tp -> Just (TraceContext tp (raw ^. #tracestate))+      schemaReference =+        case ( raw ^. #schemaRegistry,+               raw ^. #schemaSubject,+               raw ^. #schemaVersionRef,+               raw ^. #schemaId,+               raw ^. #schemaFingerprint+             ) of+          (Nothing, Nothing, Nothing, Nothing, Nothing) -> Nothing+          _ ->+            Just+              ( SchemaReference+                  (raw ^. #schemaRegistry)+                  (raw ^. #schemaSubject)+                  (raw ^. #schemaVersionRef)+                  (raw ^. #schemaId)+                  (raw ^. #schemaFingerprint)+              )+      event =+        IntegrationEvent+          { messageId = raw ^. #messageId,+            source = raw ^. #source,+            destination = raw ^. #destination,+            key = raw ^. #key,+            eventType = raw ^. #eventType,+            schemaVersion = raw ^. #schemaVersion,+            contentType = parseContentType (raw ^. #contentType),+            schemaReference,+            sourceEventId = raw ^. #sourceEventId,+            sourceGlobalPosition = raw ^. #sourceGlobalPosition,+            payloadBytes = raw ^. #payloadBytes,+            occurredAt = raw ^. #occurredAt,+            causationId = raw ^. #causationId,+            correlationId = raw ^. #correlationId,+            traceContext,+            attributes = raw ^. #attributes+          }+   in OutboxRow+        { outboxId = raw ^. #outboxId,+          event,+          status = raw ^. #status,+          attemptCount = raw ^. #attemptCount,+          nextAttemptAt = raw ^. #nextAttemptAt,+          lastError = raw ^. #lastError,+          publishedAt = raw ^. #publishedAt,+          createdAt = raw ^. #createdAt,+          updatedAt = raw ^. #updatedAt+        }
src/Keiro/Outbox/Types.hs view
@@ -1,13 +1,12 @@-{- | Shared types for the durable integration-event outbox.--The outbox is the durable handoff between "this service has decided to-publish this integration event" and "this service has actually published-it". The producer subscription writes one outbox row per mapped private-event; the publisher worker drains rows into Kafka and marks each one-sent, retryable, or dead.--}-module Keiro.Outbox.Types (-    OutboxId (..),+-- | Shared types for the durable integration-event outbox.+--+-- The outbox is the durable handoff between "this service has decided to+-- publish this integration event" and "this service has actually published+-- it". The producer subscription writes one outbox row per mapped private+-- event; the publisher worker drains rows into Kafka and marks each one+-- sent, retryable, or dead.+module Keiro.Outbox.Types+  ( OutboxId (..),     OutboxStatus (..),     OrderingPolicy (..),     BackoffSchedule (..),@@ -25,7 +24,7 @@     statusText,     parseStatus,     nextDelay,-)+  ) where  import Data.Time.Clock (NominalDiffTime)@@ -37,241 +36,231 @@  -- | Primary key of a 'keiro_outbox' row. Stable across publish retries. newtype OutboxId = OutboxId {unOutboxId :: UUID}-    deriving stock (Generic, Eq, Ord, Show)+  deriving stock (Generic, Eq, Ord, Show)  instance ToJSON OutboxId where-    toJSON = toJSON . UUID.toText . unOutboxId+  toJSON = toJSON . UUID.toText . unOutboxId  instance FromJSON OutboxId where-    parseJSON v = do-        text <- parseJSON v-        case UUID.fromText text of-            Nothing -> fail ("OutboxId: not a UUID: " <> show text)-            Just uuid -> pure (OutboxId uuid)--{- | Lifecycle state of an outbox row.+  parseJSON v = do+    text <- parseJSON v+    case UUID.fromText text of+      Nothing -> fail ("OutboxId: not a UUID: " <> show text)+      Just uuid -> pure (OutboxId uuid) -* 'OutboxPending' — never attempted.-* 'OutboxPublishing' — currently held by a publisher worker (between-  claim and the call to mark sent/failed/dead). Rows left in this state-  after a worker crash are reclaimed by 'Keiro.Outbox.outboxMaintenancePass'-  after 'publishingTimeout'.-* 'OutboxSent' — Kafka acknowledged the publish; terminal.-* 'OutboxFailed' — last attempt failed; will be retried after-  'next_attempt_at'.-* 'OutboxDead' — terminal failure after 'maxAttempts' consecutive-  failures. Stays in the table for operator inspection.--}+-- | Lifecycle state of an outbox row.+--+-- * 'OutboxPending' — never attempted.+-- * 'OutboxPublishing' — currently held by a publisher worker (between+--   claim and the call to mark sent/failed/dead). Rows left in this state+--   after a worker crash are reclaimed by 'Keiro.Outbox.outboxMaintenancePass'+--   after 'publishingTimeout'.+-- * 'OutboxSent' — Kafka acknowledged the publish; terminal.+-- * 'OutboxFailed' — last attempt failed; will be retried after+--   'next_attempt_at'.+-- * 'OutboxDead' — terminal failure after 'maxAttempts' consecutive+--   failures. Stays in the table for operator inspection. data OutboxStatus-    = OutboxPending-    | OutboxPublishing-    | OutboxSent-    | OutboxFailed-    | OutboxDead-    deriving stock (Generic, Eq, Show)--{- | Ordering policy enforced by the publisher worker's claim query.+  = OutboxPending+  | OutboxPublishing+  | OutboxSent+  | OutboxFailed+  | OutboxDead+  deriving stock (Generic, Eq, Show) -* 'PerKeyHeadOfLine' (default) — within a @source@, a non-terminal row-  with key @k@ blocks every later row with the same key. Rows with-  'Nothing' key bypass the block (Kafka does not promise cross-key order-  for null-keyed records). One stuck aggregate cannot stall traffic on-  other aggregates. Ordering is based on @created_at@, which PostgreSQL-  sets to transaction-start time; callers that concurrently enqueue the-  same key through escape hatches must serialize those enqueues themselves-  if commit order matters.-* 'PerSourceStream' — within a @source@, any non-terminal row blocks-  every later row. Use when ordering matters across keys (rare). This has-  the same @created_at@ concurrency caveat as 'PerKeyHeadOfLine'.-* 'StopTheLine' — any failure halts the worker until operator-  intervention. Use when correctness requires manual review on every-  failure.-* 'BestEffort' — failed rows do not block; explicit opt-in only. Safe-  only when published events have no per-key/causal relationship.--}+-- | Ordering policy enforced by the publisher worker's claim query.+--+-- * 'PerKeyHeadOfLine' (default) — within a @source@, a non-terminal row+--   with key @k@ blocks every later row with the same key. Rows with+--   'Nothing' key bypass the block (Kafka does not promise cross-key order+--   for null-keyed records). One stuck aggregate cannot stall traffic on+--   other aggregates. Ordering is based on @created_at@, which PostgreSQL+--   sets to transaction-start time; callers that concurrently enqueue the+--   same key through escape hatches must serialize those enqueues themselves+--   if commit order matters.+-- * 'PerSourceStream' — within a @source@, any non-terminal row blocks+--   every later row. Use when ordering matters across keys (rare). This has+--   the same @created_at@ concurrency caveat as 'PerKeyHeadOfLine'.+-- * 'StopTheLine' — any failure halts the worker until operator+--   intervention. Use when correctness requires manual review on every+--   failure.+-- * 'BestEffort' — failed rows do not block; explicit opt-in only. Safe+--   only when published events have no per-key/causal relationship. data OrderingPolicy-    = PerKeyHeadOfLine-    | PerSourceStream-    | StopTheLine-    | BestEffort-    deriving stock (Generic, Eq, Show)+  = PerKeyHeadOfLine+  | PerSourceStream+  | StopTheLine+  | BestEffort+  deriving stock (Generic, Eq, Show)  -- | Knobs for 'ExponentialBackoff'. @delay = min maxDelay (initial * multiplier ^ (attempt - 1))@. data ExponentialBackoffOptions = ExponentialBackoffOptions-    { initial :: !NominalDiffTime-    , maxDelay :: !NominalDiffTime-    , multiplier :: !Double-    }-    deriving stock (Generic, Eq, Show)--{- | Backoff curve used to compute 'next_attempt_at' after a failure.+  { initial :: !NominalDiffTime,+    maxDelay :: !NominalDiffTime,+    multiplier :: !Double+  }+  deriving stock (Generic, Eq, Show) -* 'ConstantBackoff' — fixed delay between retries.-* 'ExponentialBackoff' — exponential growth capped at @maxDelay@.--}+-- | Backoff curve used to compute 'next_attempt_at' after a failure.+--+-- * 'ConstantBackoff' — fixed delay between retries.+-- * 'ExponentialBackoff' — exponential growth capped at @maxDelay@. data BackoffSchedule-    = ConstantBackoff !NominalDiffTime-    | ExponentialBackoff !ExponentialBackoffOptions-    deriving stock (Generic, Eq, Show)+  = ConstantBackoff !NominalDiffTime+  | ExponentialBackoff !ExponentialBackoffOptions+  deriving stock (Generic, Eq, Show) -{- | Compute the retry delay for an attempt number (1-based: 1 = first-failure, 2 = second failure, …). Used by 'Keiro.Outbox.Schema.markOutboxFailedTx'-to derive @next_attempt_at@.--}+-- | Compute the retry delay for an attempt number (1-based: 1 = first+-- failure, 2 = second failure, …). Used by 'Keiro.Outbox.Schema.markOutboxFailedTx'+-- to derive @next_attempt_at@. nextDelay :: BackoffSchedule -> Int -> NominalDiffTime nextDelay (ConstantBackoff delay) _ = delay nextDelay (ExponentialBackoff opts) attempt =-    let raw = (opts ^. #initial) * realToFrac ((opts ^. #multiplier) ** fromIntegral (max 0 (attempt - 1)))-     in min (opts ^. #maxDelay) raw+  let raw = (opts ^. #initial) * realToFrac ((opts ^. #multiplier) ** fromIntegral (max 0 (attempt - 1)))+   in min (opts ^. #maxDelay) raw -{- | A request to enqueue one integration event into the outbox. Callers-generate 'outboxId' (use a random UUID for ad-hoc enqueues, a-deterministic UUID for idempotent retries from a saga/process manager).--}+-- | A request to enqueue one integration event into the outbox. Callers+-- generate 'outboxId' (use a random UUID for ad-hoc enqueues, a+-- deterministic UUID for idempotent retries from a saga/process manager). data OutboxMessage = OutboxMessage-    { outboxId :: !OutboxId-    , event :: !IntegrationEvent-    }-    deriving stock (Generic, Eq, Show)+  { outboxId :: !OutboxId,+    event :: !IntegrationEvent+  }+  deriving stock (Generic, Eq, Show) -{- | A row read back from @keiro_outbox@. Worker code consumes these to-publish to Kafka; tests use them to assert state transitions.--}+-- | A row read back from @keiro_outbox@. Worker code consumes these to+-- publish to Kafka; tests use them to assert state transitions. data OutboxRow = OutboxRow-    { outboxId :: !OutboxId-    , event :: !IntegrationEvent-    , status :: !OutboxStatus-    , attemptCount :: !Int-    , nextAttemptAt :: !UTCTime-    , lastError :: !(Maybe Text)-    , publishedAt :: !(Maybe UTCTime)-    , createdAt :: !UTCTime-    , updatedAt :: !UTCTime-    }-    deriving stock (Generic, Eq, Show)--{- | Knobs that govern one invocation of 'Keiro.Outbox.publishClaimedOutbox'.+  { outboxId :: !OutboxId,+    event :: !IntegrationEvent,+    status :: !OutboxStatus,+    attemptCount :: !Int,+    nextAttemptAt :: !UTCTime,+    lastError :: !(Maybe Text),+    publishedAt :: !(Maybe UTCTime),+    createdAt :: !UTCTime,+    updatedAt :: !UTCTime+  }+  deriving stock (Generic, Eq, Show) -The optional 'tracer' field opts the publisher into OpenTelemetry-instrumentation: when present, the publisher opens a @Producer@-kind-span around each publish call, attributing the first row's-'IntegrationEvent.destination' (topic), 'IntegrationEvent.messageId',-and Kafka key per the messaging semantic conventions. When 'tracer' is-'Nothing' (the default) the publisher emits no spans.--}+-- | Knobs that govern one invocation of 'Keiro.Outbox.publishClaimedOutbox'.+--+-- The optional 'tracer' field opts the publisher into OpenTelemetry+-- instrumentation: when present, the publisher opens a @Producer@-kind+-- span around each publish call, attributing the first row's+-- 'IntegrationEvent.destination' (topic), 'IntegrationEvent.messageId',+-- and Kafka key per the messaging semantic conventions. When 'tracer' is+-- 'Nothing' (the default) the publisher emits no spans. data OutboxPublishOptions = OutboxPublishOptions-    { batchSize :: !Int-    , maxAttempts :: !Int-    , backoff :: !BackoffSchedule-    , orderingPolicy :: !OrderingPolicy-    , publishingTimeout :: !NominalDiffTime-    , tracer :: !(Maybe Tracer)-    }-    deriving stock (Generic)+  { batchSize :: !Int,+    maxAttempts :: !Int,+    backoff :: !BackoffSchedule,+    orderingPolicy :: !OrderingPolicy,+    publishingTimeout :: !NominalDiffTime,+    tracer :: !(Maybe Tracer)+  }+  deriving stock (Generic)  data OutboxPublishConfigError-    = InvalidOutboxBatchSize !Int-    | InvalidOutboxMaxAttempts !Int-    | InvalidOutboxPublishingTimeout !NominalDiffTime-    | InvalidConstantBackoff !NominalDiffTime-    | InvalidExponentialBackoffInitial !NominalDiffTime-    | InvalidExponentialBackoffMultiplier !Double-    | InvalidExponentialBackoffMaxDelay !NominalDiffTime !NominalDiffTime-    deriving stock (Generic, Eq, Show)--{- | Aggregate result of one publisher pass.+  = InvalidOutboxBatchSize !Int+  | InvalidOutboxMaxAttempts !Int+  | InvalidOutboxPublishingTimeout !NominalDiffTime+  | InvalidConstantBackoff !NominalDiffTime+  | InvalidExponentialBackoffInitial !NominalDiffTime+  | InvalidExponentialBackoffMultiplier !Double+  | InvalidExponentialBackoffMaxDelay !NominalDiffTime !NominalDiffTime+  deriving stock (Generic, Eq, Show) -@published + retried + dead@ equals the number of rows claimed. 'retried'-includes rows that were skipped because an earlier row in the same ordered-publish group failed; those rows are returned to @failed@ without consuming-an attempt. 'haltedOn' is populated only by 'StopTheLine' policy and names-the failed pivot row, which is already counted in 'retried' or 'dead'.--}+-- | Aggregate result of one publisher pass.+--+-- @published + retried + dead@ equals the number of rows claimed. 'retried'+-- includes rows that were skipped because an earlier row in the same ordered+-- publish group failed; those rows are returned to @failed@ without consuming+-- an attempt. 'haltedOn' is populated only by 'StopTheLine' policy and names+-- the failed pivot row, which is already counted in 'retried' or 'dead'. data OutboxPublishSummary = OutboxPublishSummary-    { claimed :: !Int-    , published :: !Int-    , retried :: !Int-    , dead :: !Int-    , haltedOn :: !(Maybe OutboxId)-    }-    deriving stock (Generic, Eq, Show)--{- | Knobs for 'Keiro.Outbox.outboxMaintenancePass'.+  { claimed :: !Int,+    published :: !Int,+    retried :: !Int,+    dead :: !Int,+    haltedOn :: !(Maybe OutboxId)+  }+  deriving stock (Generic, Eq, Show) -Schedule maintenance less frequently than publish passes; it owns crash-reclamation and backlog gauge sampling.--}+-- | Knobs for 'Keiro.Outbox.outboxMaintenancePass'.+--+-- Schedule maintenance less frequently than publish passes; it owns crash+-- reclamation and backlog gauge sampling. data OutboxMaintenanceOptions = OutboxMaintenanceOptions-    { maxAttempts :: !Int-    , publishingTimeout :: !NominalDiffTime-    }-    deriving stock (Generic, Eq, Show)+  { maxAttempts :: !Int,+    publishingTimeout :: !NominalDiffTime+  }+  deriving stock (Generic, Eq, Show)  -- | Result of one outbox maintenance pass. data OutboxMaintenanceSummary = OutboxMaintenanceSummary-    { requeued :: !Int-    , deadLettered :: !Int-    , backlog :: !Int-    }-    deriving stock (Generic, Eq, Show)+  { requeued :: !Int,+    deadLettered :: !Int,+    backlog :: !Int+  }+  deriving stock (Generic, Eq, Show) -{- | Sensible defaults: batch of 32, ten retry attempts, two-second-constant backoff, per-key head-of-line ordering.--}+-- | Sensible defaults: batch of 32, ten retry attempts, two-second+-- constant backoff, per-key head-of-line ordering. defaultPublishOptions :: OutboxPublishOptions defaultPublishOptions =-    OutboxPublishOptions-        { batchSize = 32-        , maxAttempts = 10-        , backoff = ConstantBackoff 2-        , orderingPolicy = PerKeyHeadOfLine-        , publishingTimeout = 300-        , tracer = Nothing-        }+  OutboxPublishOptions+    { batchSize = 32,+      maxAttempts = 10,+      backoff = ConstantBackoff 2,+      orderingPolicy = PerKeyHeadOfLine,+      publishingTimeout = 300,+      tracer = Nothing+    }  -- | Maintenance defaults match the publisher's retry ceiling and stale-row timeout. defaultMaintenanceOptions :: OutboxMaintenanceOptions defaultMaintenanceOptions =-    OutboxMaintenanceOptions-        { maxAttempts = defaultPublishOptions ^. #maxAttempts-        , publishingTimeout = defaultPublishOptions ^. #publishingTimeout-        }+  OutboxMaintenanceOptions+    { maxAttempts = defaultPublishOptions ^. #maxAttempts,+      publishingTimeout = defaultPublishOptions ^. #publishingTimeout+    }  -- | Validate outbox publisher options before starting a worker. mkOutboxPublishOptions :: OutboxPublishOptions -> Either OutboxPublishConfigError OutboxPublishOptions mkOutboxPublishOptions opts-    | opts ^. #batchSize < 1 = Left (InvalidOutboxBatchSize (opts ^. #batchSize))-    | opts ^. #maxAttempts < 1 = Left (InvalidOutboxMaxAttempts (opts ^. #maxAttempts))-    | opts ^. #publishingTimeout <= 0 = Left (InvalidOutboxPublishingTimeout (opts ^. #publishingTimeout))-    | otherwise = opts <$ validateBackoff (opts ^. #backoff)+  | opts ^. #batchSize < 1 = Left (InvalidOutboxBatchSize (opts ^. #batchSize))+  | opts ^. #maxAttempts < 1 = Left (InvalidOutboxMaxAttempts (opts ^. #maxAttempts))+  | opts ^. #publishingTimeout <= 0 = Left (InvalidOutboxPublishingTimeout (opts ^. #publishingTimeout))+  | otherwise = opts <$ validateBackoff (opts ^. #backoff)  validateBackoff :: BackoffSchedule -> Either OutboxPublishConfigError () validateBackoff = \case-    ConstantBackoff delay-        | delay < 0 -> Left (InvalidConstantBackoff delay)-        | otherwise -> Right ()-    ExponentialBackoff backoff-        | backoff ^. #initial <= 0 -> Left (InvalidExponentialBackoffInitial (backoff ^. #initial))-        | backoff ^. #multiplier < 1 -> Left (InvalidExponentialBackoffMultiplier (backoff ^. #multiplier))-        | backoff ^. #maxDelay < backoff ^. #initial ->-            Left (InvalidExponentialBackoffMaxDelay (backoff ^. #initial) (backoff ^. #maxDelay))-        | otherwise -> Right ()+  ConstantBackoff delay+    | delay < 0 -> Left (InvalidConstantBackoff delay)+    | otherwise -> Right ()+  ExponentialBackoff backoff+    | backoff ^. #initial <= 0 -> Left (InvalidExponentialBackoffInitial (backoff ^. #initial))+    | backoff ^. #multiplier < 1 -> Left (InvalidExponentialBackoffMultiplier (backoff ^. #multiplier))+    | backoff ^. #maxDelay < backoff ^. #initial ->+        Left (InvalidExponentialBackoffMaxDelay (backoff ^. #initial) (backoff ^. #maxDelay))+    | otherwise -> Right ()  -- | Wire representation of 'OutboxStatus' used in the @status@ column. statusText :: OutboxStatus -> Text statusText = \case-    OutboxPending -> "pending"-    OutboxPublishing -> "publishing"-    OutboxSent -> "sent"-    OutboxFailed -> "failed"-    OutboxDead -> "dead"+  OutboxPending -> "pending"+  OutboxPublishing -> "publishing"+  OutboxSent -> "sent"+  OutboxFailed -> "failed"+  OutboxDead -> "dead"  -- | Inverse of 'statusText'. Unknown database values are decode failures. parseStatus :: Text -> Either Text OutboxStatus parseStatus = \case-    "pending" -> Right OutboxPending-    "publishing" -> Right OutboxPublishing-    "sent" -> Right OutboxSent-    "failed" -> Right OutboxFailed-    "dead" -> Right OutboxDead-    bad -> Left ("unknown keiro_outbox.status: " <> bad)+  "pending" -> Right OutboxPending+  "publishing" -> Right OutboxPublishing+  "sent" -> Right OutboxSent+  "failed" -> Right OutboxFailed+  "dead" -> Right OutboxDead+  bad -> Left ("unknown keiro_outbox.status: " <> bad)
src/Keiro/ProcessManager.hs view
@@ -1,731 +1,717 @@-{- | Stateful coordination across aggregates: the process manager (saga).--A 'ProcessManager' reacts to an incoming event by stepping its /own/ state-machine — a private \"manager\" event stream, keyed by a correlation id — and,-in the same turn, dispatching commands to /target/ aggregates and scheduling-timers. It is the stateful counterpart of "Keiro.Router": where a router-resolves targets from a read model and holds no state, a process manager-folds the events it has seen into durable manager state and decides what to-do next from that state.--Every write — the manager-state append, each dispatched command, each timer-— is keyed by a 'deterministicCommandId' derived from-@(name, correlation, source event id, emit index)@. The manager pre-checks-each id with 'eventAlreadyIn' and folds the store's duplicate rejection into-a benign 'PMCommandDuplicate' \/ 'PMStateDuplicate'. Replaying the same-source event therefore appends nothing new, which is what makes the worker-crash-safe under at-least-once delivery.--Use 'runProcessManagerOnce' to react to a single event, or-'runProcessManagerWorker' to run the manager as a live subscription over a-Shibuya adapter. Worker acks are finalized exactly once: successful and duplicate-dispatches ack 'AckOk', transient store failures retry, systemic deterministic-failures halt, rejection-class failures follow 'RejectedCommandPolicy', and-undecodable messages follow the configured 'PoisonPolicy'.--=== Rejected commands and saga history--'RejectedHalt' is the safe default: the subscription stops without advancing,-so an operator cannot miss the failure. 'RejectedDeadLetter' instead writes a-durable "Keiro.DeadLetter.DispatchDeadLetter" and acknowledges the source-event; 'RejectedSkip' acknowledges and records only the metric. Prefer making a-target command total in its Keiki transducer (for example, an explicit no-op-transition for a benign business rejection) so no policy escape hatch is-needed.--For a process manager, dead-lettering a target dispatch creates an important-history split: the manager's own state stream has recorded its reaction, but-the target command never applied. Keiro cannot append a generic correction to-the manager stream because an event unknown to the manager's transducer would-make that stream fail replay. If saga history must reflect the failure, model a-domain-specific @DispatchFailed@-style command and event in the manager and-drive it from 'Keiro.DeadLetter.listDispatchDeadLetters' through an operator-runbook or automation. Otherwise, the dead-letter row is the durable witness.-Manager-state rejection itself has no such split because no manager event was-appended; its record uses emit index @-1@.--=== Bounded retries and source-event dead letters--On a Kiroku-backed Shibuya adapter, a transient failure finalizes 'AckRetry',-but retries are bounded by the Kiroku subscription's @RetryPolicy@. Its-@retryMaxAttempts@ counts total deliveries and defaults to five. When the bound-is exhausted, Kiroku records the /source event/ in @kiroku.dead_letters@ with-structured reason kind @max_attempts_exceeded@ and atomically advances the-checkpoint. The manager will not see that event again unless an operator-replays it through @Keiro.DeadLetter.Replay@. Install-'Keiro.Telemetry.kirokuEventBridge' on Kiroku's @eventHandler@ to observe the-terminal transition.--The adapter's @KirokuAdapterConfig@ does not currently expose @retryPolicy@, so-that path uses Kiroku's default bound. The sharded path is configurable:-'Keiro.Subscription.Shard.Worker.runShardedSubscriptionGroupAck' forwards-'Keiro.Subscription.Shard.Worker.ShardedWorkerOptions.retryPolicy' into the-same Kiroku acknowledgement ladder. A shard handler that dispatches commands-can use 'decideForFailures' and 'isRejectionClass' to classify outcomes, then-map the decision to its existing @ShardAck@ reply.--=== Correlation, ordering, and transaction boundaries--Events from one originating stream retain that stream's append order. Kiroku-consumer groups hash the originating stream id to a stable member, so sharding-does not split one stream across readers. Events from /different/ streams that-'correlate' to the same manager instance have no business-order guarantee,-however. Their append transactions race for global positions and, under-sharding, the streams may be processed concurrently by different members. A-retry on one member does not stop another member from advancing.--For example, both @payment-ORD1@'s @PaymentCaptured@ and @shipment-ORD1@'s-@ShipmentAllocated@ may correlate to order @ORD1@. The manager must accept-@PaymentCaptured@ then @ShipmentAllocated@ /and/ the reverse, normally with-states that record one fact while waiting for the other. An unsharded Kiroku-subscription processes its observed global order serially, including retries,-but that order still reflects append timing rather than a domain sequence.--Rule of thumb: 'correlate' may join streams freely, but every such join must be-order-insensitive. When a strict sequence is required, enforce it in the-manager's own state machine — for example with an explicit no-op/waiting state-and a timer-driven retry, or a modeled rejection handled by the dead-letter-policy — never by assuming delivery order.--The persistence boundary is also intentionally smaller than one whole saga-reaction. A manager event and its timers commit together when the manager-command appends; a timer-only no-op reaction schedules its timers in a separate-transaction. Each target command and its inline projections then commit in-their own transaction. A crash or rejected target can therefore leave durable-manager history without every target write. Deterministic ids make source-event-replay fill the missing writes without duplicating completed ones; the rejected-command section above describes the case that is deliberately acknowledged-instead.--}-module Keiro.ProcessManager (-    -- * Definition-    ProcessManager (..),-    ProcessManagerAction (..),-    PMCommand (..),--    -- * Results-    ProcessManagerResult (..),-    PMCommandResult (..),-    PMStateResult (..),--    -- * Running-    PoisonPolicy (..),-    RejectedCommandPolicy (..),-    DispatchFailure (..),-    WorkerOptions (..),-    defaultWorkerOptions,-    isTransientStoreError,-    isTransientCommandError,-    isRejectionClass,-    decideForFailures,-    ackForCommandError,-    runProcessManagerOnce,-    runProcessManagerWorkerWith,-    runProcessManagerWorker,--    -- * Idempotency primitives-    deterministicCommandId,-    eventAlreadyIn,-    confirmBenignDuplicate,-)-where--import Data.Coerce (coerce)-import Data.Text qualified as Text-import Data.UUID qualified as UUID-import Data.UUID.V5 qualified as UUID.V5-import Effectful (Eff, IOE, (:>))-import Effectful.Error.Static (Error, tryError)-import GHC.Stack (HasCallStack)-import Keiki.Core (BoolAlg, RegFile)-import Keiro.Command (CommandError (..), CommandResult, RunCommandOptions, commandErrorClass, runCommandWithSql)-import Keiro.DeadLetter (DispatchDeadLetter (..), DispatcherKind (..), recordDispatchDeadLetter)-import Keiro.EventStream (EventStream)-import Keiro.EventStream.Validate (ValidatedEventStream, unvalidated)-import Keiro.Prelude-import Keiro.Projection (InlineProjection, runCommandWithProjections)-import Keiro.Stream (Stream)-import Keiro.Telemetry (KeiroMetrics, recordDispatchDeadLettered, recordDispatchDuplicate, recordDispatchFailed, recordDispatchPoison)-import Keiro.Timer (TimerRequest, scheduleTimerTx)-import Kiroku.Store.Effect (Store)-import Kiroku.Store.Effect.Resource (KirokuStoreResource)-import Kiroku.Store.Error (StoreError (..))-import Kiroku.Store.Read (eventExistsInStream)-import Kiroku.Store.Transaction (runTransaction)-import Kiroku.Store.Types (EventId (..), RecordedEvent)-import Kiroku.Store.Types qualified as StoreTypes-import Shibuya.Adapter (Adapter (..))-import Shibuya.Core.Ack (AckDecision (..), DeadLetterReason (..), HaltReason (..), RetryDelay (..))-import Shibuya.Core.AckHandle (AckHandle (..))-import Shibuya.Core.Ingested (Ingested (..))-import Shibuya.Core.Types (Attempt (..), Envelope (..))-import Streamly.Data.Fold qualified as Fold-import Streamly.Data.Stream qualified as Streamly-import Prelude (any, filter, fromIntegral, length, not, uncurry, zip, (&&), (+))--{- | A process manager wiring together a manager state machine and the target-aggregate it drives.--* 'name' — stable identity; part of every deterministic write id.-* 'correlate' — derives the correlation key for an input event, selecting-  which manager instance handles it.-* 'eventStream' — the manager's own 'EventStream'; its events record the-  saga's progress.-* 'streamFor' — maps a correlation key to the manager's 'Stream' handle.-* 'targetEventStream' — the aggregate that dispatched commands are sent to.-* 'targetProjections' — inline projections for the target aggregate, run in-  the same transaction as each dispatched command's append. Return @[]@ for-  append-only dispatch.-* 'handle' — the pure reaction: given an input event, produce the-  manager-state command, the target commands to dispatch, and any timers to-  schedule.--}-data ProcessManager input phi rs s ci co targetPhi targetRs targetState targetCi targetCo = ProcessManager-    { name :: !Text-    , correlate :: !(input -> Text)-    , eventStream :: !(ValidatedEventStream phi rs s ci co)-    , streamFor :: !(Text -> Stream (EventStream phi rs s ci co))-    , targetEventStream :: !(ValidatedEventStream targetPhi targetRs targetState targetCi targetCo)-    , targetProjections :: !(Stream targetCi -> [InlineProjection targetCo])-    {- ^ Inline projections for the target aggregate, run in the same transaction-    as each dispatched command's append. Return @[]@ for append-only dispatch.-    -}-    , handle :: !(input -> ProcessManagerAction ci targetCi)-    }-    deriving stock (Generic)--{- | What a process manager decides to do for one input event: advance its own-state with 'command', dispatch zero or more target 'commands', and schedule-zero or more 'timers'. All three are applied atomically with crash-safe-idempotency by 'runProcessManagerOnce'.--}-data ProcessManagerAction ci targetCi = ProcessManagerAction-    { command :: !ci-    , commands :: ![PMCommand targetCi]-    , timers :: ![TimerRequest]-    }-    deriving stock (Generic)---- | A single command addressed to a specific target stream.-data PMCommand targetCi = PMCommand-    { target :: !(Stream targetCi)-    , command :: !targetCi-    }-    deriving stock (Generic, Eq, Show)---- | Outcome of one dispatched target command.-data PMCommandResult target-    = -- | The command appended events (carries the 'CommandResult').-      PMCommandAppended !(CommandResult target)-    | {- | The command was already applied (idempotent replay); carries the-      deterministic id that already existed.-      -}-      PMCommandDuplicate !EventId-    | {- | The command failed in the named target stream; the worker classifies-      the error. Transient failures retry, rejection-class failures follow-      'RejectedCommandPolicy', and systemic deterministic failures halt.-      -}-      PMCommandFailed !StoreTypes.StreamName !CommandError-    deriving stock (Generic, Eq, Show)--{- | Outcome of the manager's own state append. Unlike 'PMCommandResult' there-is no failure case — a manager-state append that genuinely errors aborts the-whole reaction via an outer @Left@ 'CommandError'.--}-data PMStateResult target-    = PMStateAppended !(CommandResult target)-    | PMStateDuplicate !EventId-    deriving stock (Generic, Eq, Show)--{- | The complete result of reacting to one event: how the manager state-advanced, the outcome of each dispatched command in order, and how many-timers were scheduled.--}-data ProcessManagerResult managerTarget commandTarget = ProcessManagerResult-    { managerResult :: !(PMStateResult managerTarget)-    , commandResults :: ![PMCommandResult commandTarget]-    , timersScheduled :: !Int-    }-    deriving stock (Generic, Eq, Show)---- | What a worker does with a message its decoder cannot parse.-data PoisonPolicy es msg-    = PoisonHalt-    | PoisonSkip !(Envelope msg -> Eff es ())-    | PoisonDeadLetter !(Envelope msg -> Eff es ())---- | What a worker does when every failed dispatch is a rejection-class error.-data RejectedCommandPolicy-    = -- | Halt without acknowledging so the source event replays. This is the default.-      RejectedHalt-    | -- | Persist a durable dispatch dead letter and acknowledge the source event.-      RejectedDeadLetter-    | -- | Acknowledge and count the rejection without persisting a record.-      RejectedSkip-    deriving stock (Generic, Eq, Show)---- | One failed dispatch with the target identity needed by worker policy.-data DispatchFailure = DispatchFailure-    { emitIndex :: !Int-    , targetStreamName :: !StoreTypes.StreamName-    , commandError :: !CommandError-    }-    deriving stock (Generic, Eq, Show)---- | Worker-level knobs shared by the process-manager and router workers.-data WorkerOptions es msg = WorkerOptions-    { poisonPolicy :: !(PoisonPolicy es msg)-    , rejectedCommandPolicy :: !RejectedCommandPolicy-    , transientRetryDelay :: !RetryDelay-    , metrics :: !(Maybe KeiroMetrics)-    }-    deriving stock (Generic)--defaultWorkerOptions :: WorkerOptions es msg-defaultWorkerOptions =-    WorkerOptions-        { poisonPolicy = PoisonHalt-        , rejectedCommandPolicy = RejectedHalt-        , transientRetryDelay = RetryDelay 5-        , metrics = Nothing-        }--isTransientStoreError :: StoreError -> Bool-isTransientStoreError = \case-    ConnectionLost{} -> True-    PoolAcquisitionTimeout -> True-    ConnectionError{} -> True-    WrongExpectedVersion{} -> True-    StreamAlreadyExists{} -> True-    EmptyAppendBatch{} -> False-    StreamNotFound{} -> False-    ReservedStreamName{} -> False-    StreamNameTooLong{} -> False-    DuplicateEvent{} -> False-    EventAlreadyLinked{} -> False-    LinkSourceEventMissing{} -> False-    UnexpectedServerError{} -> False--isTransientCommandError :: CommandError -> Bool-isTransientCommandError = \case-    StoreFailed err -> isTransientStoreError err-    RetryExhausted _ err -> isTransientStoreError err-    ConflictFixpoint _ err -> isTransientStoreError err-    HydrationDecodeFailed{} -> False-    HydrationReplayFailed{} -> False-    HydrationGapDetected{} -> False-    CommandRejected -> False-    CommandAmbiguous{} -> False-    EncodeFailed{} -> False---- | Whether a command error is a per-command rejection covered by worker policy.-isRejectionClass :: CommandError -> Bool-isRejectionClass = \case-    CommandRejected -> True-    CommandAmbiguous{} -> True-    _ -> False--{- | Classify a group of failed dispatches and choose one acknowledgement.--Systemic deterministic errors always halt. Any transient error retries the-whole source event. Only an all-rejection group reaches the configured-'RejectedCommandPolicy'. Dead-letter writes are idempotent under redelivery.--}-decideForFailures ::-    (IOE :> es, Store :> es) =>-    WorkerOptions es msg ->-    DispatcherKind ->-    Text ->-    Text ->-    RecordedEvent ->-    Int ->-    [DispatchFailure] ->-    Eff es AckDecision-decideForFailures workerOptions dispatcherKind dispatcherName correlationId sourceEvent attemptCount failures =-    case filter isSystemicDeterministic failures of-        failure : _ -> pure (haltFor failure)-        []-            | any (isTransientCommandError . (^. #commandError)) failures ->-                pure (AckRetry (workerOptions ^. #transientRetryDelay))-            | otherwise ->-                case failures of-                    [] -> pure AckOk-                    _ -> decideRejected-  where-    isSystemicDeterministic failure =-        let err = failure ^. #commandError-         in not (isTransientCommandError err) && not (isRejectionClass err)--    haltFor failure =-        AckHalt (HaltFatal (Text.pack (show (failure ^. #commandError))))--    decideRejected =-        case workerOptions ^. #rejectedCommandPolicy of-            RejectedHalt -> pure (haltFor (headFailure failures))-            RejectedDeadLetter -> do-                traverse_ recordFailure failures-                recordHandled-                pure AckOk-            RejectedSkip -> do-                recordHandled-                pure AckOk--    recordHandled =-        recordDispatchDeadLettered-            (workerOptions ^. #metrics)-            (fromIntegral (length failures))--    recordFailure failure =-        let err = failure ^. #commandError-         in recordDispatchDeadLetter-                DispatchDeadLetter-                    { dispatcherKind = dispatcherKind-                    , dispatcherName = dispatcherName-                    , correlationId = correlationId-                    , sourceEventId = sourceEvent ^. #eventId-                    , sourceGlobalPosition = sourceEvent ^. #globalPosition-                    , emitIndex = failure ^. #emitIndex-                    , targetStreamName = failure ^. #targetStreamName-                    , errorClass = commandErrorClass err-                    , errorDetail = Text.pack (show err)-                    , attemptCount = max 1 attemptCount-                    }--    headFailure = \case-        failure : _ -> failure-        [] -> DispatchFailure (-1) (StoreTypes.StreamName "unknown") CommandRejected--ackForCommandError :: RetryDelay -> CommandError -> AckDecision-ackForCommandError delay err-    | isTransientCommandError err = AckRetry delay-    | otherwise = AckHalt (HaltFatal (Text.pack (show err)))--{- | Derive a stable, collision-resistant 'EventId' for a manager write from-@(manager name, correlation id, source event id, emit index)@ via a v5 UUID.--The same inputs always yield the same id, so a replayed source event-produces the same write ids and the store's uniqueness constraint collapses-the duplicate. The manager-state append uses an emit index of @-1@ to keep-it distinct from the dispatched commands (which start at @0@). This positional-index is sound because 'handle' is pure and therefore returns the same command-order for the same input. The effectful router uses-'Keiro.Router.deterministicRouterCommandId' instead, retaining this positional-id only as a transition probe for pre-upgrade router dispatches.--}-deterministicCommandId :: Text -> Text -> EventId -> Int -> EventId-deterministicCommandId managerName correlationId sourceEventId emitIndex =-    EventId-        $ UUID.V5.generateNamed UUID.V5.namespaceURL-        $ fmap (fromIntegral . fromEnum)-        $ Text.unpack-        $ Text.intercalate-            ":"-            [ "keiro"-            , "process-manager"-            , managerName-            , correlationId-            , UUID.toText (eventIdToUuid sourceEventId)-            , Text.pack (show emitIndex)-            ]--{- | React to a single source event: advance the manager's state, dispatch-its target commands, and schedule its timers — each under a deterministic,-idempotent write id.--The manager-state append and its timers commit in one transaction; each-target command is then dispatched (with its inline projections) in its own.-A duplicate manager append short-circuits to 'PMStateDuplicate' but still-re-runs the dispatch loop, so a crash between the state append and a-command dispatch is recovered on replay. Returns @Left@ only when the-manager-state append fails for a non-duplicate reason; per-command failures-are reported inside 'commandResults'.--}-runProcessManagerOnce ::-    forall input phi rs s ci co targetPhi targetRs targetState targetCi targetCo es.-    ( HasCallStack-    , IOE :> es-    , Store :> es-    , Error StoreError :> es-    , KirokuStoreResource :> es-    , BoolAlg phi (RegFile rs, ci)-    , BoolAlg targetPhi (RegFile targetRs, targetCi)-    , Eq co-    , Eq targetCo-    ) =>-    RunCommandOptions ->-    ProcessManager input phi rs s ci co targetPhi targetRs targetState targetCi targetCo ->-    RecordedEvent ->-    input ->-    Eff es (Either CommandError (ProcessManagerResult (EventStream phi rs s ci co) (EventStream targetPhi targetRs targetState targetCi targetCo)))-runProcessManagerOnce options manager sourceEvent input = do-    let correlationId = (manager ^. #correlate) input-        action = (manager ^. #handle) input-        managerStream = (manager ^. #streamFor) correlationId-        managerEventId = deterministicCommandId (manager ^. #name) correlationId (sourceEvent ^. #eventId) (-1)-        managerOptions = options & #eventIds .~ [managerEventId]-        managerStreamName = ((unvalidated (manager ^. #eventStream)) ^. #resolveStreamName) managerStream-    managerAlreadyProcessed <- eventAlreadyIn options managerStreamName managerEventId-    if managerAlreadyProcessed-        then finish correlationId (PMStateDuplicate managerEventId) action-        else do-            managerOutcome <--                runCommandWithSql-                    managerOptions-                    (manager ^. #eventStream)-                    managerStream-                    (action ^. #command)-                    (\_ -> traverse_ scheduleTimerTx (action ^. #timers))-            case managerOutcome of-                Left err -> do-                    benign <- confirmBenignDuplicate managerStreamName managerEventId err-                    if benign-                        then finish correlationId (PMStateDuplicate managerEventId) action-                        else pure (Left err)-                Right (managerResult, scheduledInAppend) -> do-                    -- No-op manager commands do not execute runCommandWithSql's callback,-                    -- so schedule timer-only reactions explicitly.-                    case scheduledInAppend of-                        Nothing -> runTransaction (traverse_ scheduleTimerTx (action ^. #timers))-                        Just () -> pure ()-                    finish correlationId (PMStateAppended managerResult) action-  where-    finish correlationId managerResult action = do-        commandResults <- dispatchCommands correlationId (sourceEvent ^. #eventId) (action ^. #commands)-        pure-            $ Right-                ProcessManagerResult-                    { managerResult = managerResult-                    , commandResults = commandResults-                    , timersScheduled = length (action ^. #timers)-                    }--    dispatchCommands correlationId sourceEventId commands =-        traverse-            (uncurry (dispatchCommand correlationId sourceEventId))-            (zip [0 ..] commands)--    dispatchCommand correlationId sourceEventId emitIndex command = do-        let commandId = deterministicCommandId (manager ^. #name) correlationId sourceEventId emitIndex-            targetOptions = options & #eventIds .~ [commandId]-            targetStream = retarget (command ^. #target)-            targetStreamName = ((unvalidated (manager ^. #targetEventStream)) ^. #resolveStreamName) targetStream-        commandAlreadyProcessed <- eventAlreadyIn options targetStreamName commandId-        if commandAlreadyProcessed-            then pure (PMCommandDuplicate commandId)-            else do-                outcome <--                    runCommandWithProjections-                        targetOptions-                        (manager ^. #targetEventStream)-                        targetStream-                        (command ^. #command)-                        ((manager ^. #targetProjections) (command ^. #target))-                case outcome of-                    Right result -> pure (PMCommandAppended result)-                    Left err -> do-                        benign <- confirmBenignDuplicate targetStreamName commandId err-                        pure $ if benign then PMCommandDuplicate commandId else PMCommandFailed targetStreamName err--    retarget :: Stream targetCi -> Stream (EventStream targetPhi targetRs targetState targetCi targetCo)-    retarget = coerce--{- | Run a process manager as a live subscription draining a Shibuya adapter with-'defaultWorkerOptions'.--Use 'runProcessManagerWorkerWith' to override poison-message handling, rejected-command handling, transient retry delay, or dispatch metrics. Every ingested message's ack handle is-finalized exactly once. Successful and duplicate dispatches finalize 'AckOk';-transient store failures finalize 'AckRetry'; rejection-class failures follow-'RejectedCommandPolicy'; other deterministic failures finalize 'AckHalt';-undecodable messages follow the configured 'PoisonPolicy'. Under-'RejectedDeadLetter', see the module-level saga-history contract before opting-in. On a Kiroku-backed adapter, each 'AckRetry' redelivery is bounded by the-subscription @RetryPolicy@ (five total deliveries by default). Exhaustion-dead-letters the source event in @kiroku.dead_letters@ and advances the-checkpoint; @KirokuAdapterConfig@ does not currently expose that bound. Observe-the terminal event with 'Keiro.Telemetry.kirokuEventBridge' and replay it with-@Keiro.DeadLetter.Replay@ when appropriate.--}-runProcessManagerWorker ::-    forall msg input phi rs s ci co targetPhi targetRs targetState targetCi targetCo es.-    ( HasCallStack-    , IOE :> es-    , Store :> es-    , Error StoreError :> es-    , KirokuStoreResource :> es-    , BoolAlg phi (RegFile rs, ci)-    , BoolAlg targetPhi (RegFile targetRs, targetCi)-    , Eq co-    , Eq targetCo-    ) =>-    RunCommandOptions ->-    ProcessManager input phi rs s ci co targetPhi targetRs targetState targetCi targetCo ->-    Adapter es msg ->-    (msg -> Maybe (RecordedEvent, input)) ->-    Eff es ()-runProcessManagerWorker =-    runProcessManagerWorkerWith defaultWorkerOptions--runProcessManagerWorkerWith ::-    forall msg input phi rs s ci co targetPhi targetRs targetState targetCi targetCo es.-    ( HasCallStack-    , IOE :> es-    , Store :> es-    , Error StoreError :> es-    , KirokuStoreResource :> es-    , BoolAlg phi (RegFile rs, ci)-    , BoolAlg targetPhi (RegFile targetRs, targetCi)-    , Eq co-    , Eq targetCo-    ) =>-    WorkerOptions es msg ->-    RunCommandOptions ->-    ProcessManager input phi rs s ci co targetPhi targetRs targetState targetCi targetCo ->-    Adapter es msg ->-    (msg -> Maybe (RecordedEvent, input)) ->-    Eff es ()-runProcessManagerWorkerWith workerOptions options manager Adapter{source = adapterSource} decodeMessage =-    Streamly.fold Fold.drain-        $ Streamly.mapM handleIngested adapterSource-  where-    handleIngested :: Ingested es msg -> Eff es AckDecision-    handleIngested Ingested{envelope = env@Envelope{payload = message}, ack = AckHandle finalizeAck} = do-        decision <- case decodeMessage message of-            Nothing -> decideForPoison workerOptions "process-manager worker could not decode message" env-            Just (recorded, input) -> do-                let correlationId = (manager ^. #correlate) input-                    managerStream = (manager ^. #streamFor) correlationId-                    managerStreamName = ((unvalidated (manager ^. #eventStream)) ^. #resolveStreamName) managerStream-                    attemptCount = envelopeAttemptCount env-                outcome <- tryError @StoreError (runProcessManagerOnce options manager recorded input)-                case outcome of-                    Left (_, storeErr) -> do-                        recordDispatchFailed (workerOptions ^. #metrics) 1-                        pure (ackForThrownStoreError (workerOptions ^. #transientRetryDelay) storeErr)-                    Right (Left err) -> do-                        recordDispatchFailed (workerOptions ^. #metrics) 1-                        decideForFailures-                            workerOptions-                            DispatcherProcessManager-                            (manager ^. #name)-                            correlationId-                            recorded-                            attemptCount-                            [DispatchFailure (-1) managerStreamName err]-                    Right (Right result) ->-                        ackForResults-                            workerOptions-                            (manager ^. #name)-                            correlationId-                            recorded-                            attemptCount-                            (result ^. #managerResult)-                            (result ^. #commandResults)-        finalizeAck decision-        pure decision--ackForThrownStoreError :: RetryDelay -> StoreError -> AckDecision-ackForThrownStoreError delay = ackForCommandError delay . StoreFailed--ackForResults ::-    (IOE :> es, Store :> es) =>-    WorkerOptions es msg ->-    Text ->-    Text ->-    RecordedEvent ->-    Int ->-    PMStateResult managerTarget ->-    [PMCommandResult commandTarget] ->-    Eff es AckDecision-ackForResults workerOptions managerName correlationId sourceEvent attemptCount managerResult commandResults = do-    let duplicateCount = stateDuplicateCount managerResult + commandDuplicateCount commandResults-        failures =-            [ DispatchFailure emitIndex targetStreamName err-            | (emitIndex, PMCommandFailed targetStreamName err) <- zip [0 ..] commandResults-            ]-    recordDispatchDuplicate (workerOptions ^. #metrics) duplicateCount-    recordDispatchFailed (workerOptions ^. #metrics) (fromIntegral (length failures))-    decideForFailures-        workerOptions-        DispatcherProcessManager-        managerName-        correlationId-        sourceEvent-        attemptCount-        failures--stateDuplicateCount :: PMStateResult target -> Int64-stateDuplicateCount = \case-    PMStateDuplicate{} -> 1-    PMStateAppended{} -> 0--commandDuplicateCount :: [PMCommandResult target] -> Int64-commandDuplicateCount =-    fromIntegral . length . filter isDuplicateResult-  where-    isDuplicateResult = \case-        PMCommandDuplicate{} -> True-        _ -> False--envelopeAttemptCount :: Envelope msg -> Int-envelopeAttemptCount env =-    case env ^. #attempt of-        Nothing -> 1-        Just (Attempt attempt) -> fromIntegral attempt + 1--decideForPoison ::-    (IOE :> es) =>-    WorkerOptions es msg ->-    Text ->-    Envelope msg ->-    Eff es AckDecision-decideForPoison workerOptions reason env = do-    recordDispatchPoison (workerOptions ^. #metrics) 1-    case workerOptions ^. #poisonPolicy of-        PoisonHalt -> pure (AckHalt (HaltFatal reason))-        PoisonSkip callback -> do-            callback env-            pure AckOk-        PoisonDeadLetter callback -> do-            callback env-            pure (AckDeadLetter (InvalidPayload reason))--eventIdToUuid :: EventId -> UUID.UUID-eventIdToUuid (EventId uuid) = uuid--{- | Check whether an event with the given id is already present in a live stream.-Used as the pre-dispatch idempotency guard so a-command that was already applied on a prior (possibly crashed) attempt is-recognized as a duplicate before re-running it.--}-eventAlreadyIn ::-    (Store :> es) =>-    RunCommandOptions ->-    StoreTypes.StreamName ->-    EventId ->-    Eff es Bool-eventAlreadyIn _options streamName eventId =-    eventExistsInStream streamName eventId--{- | Decide whether a failed append is a benign duplicate of the write just-attempted: whether @ourId@ is genuinely present in @streamName@.--Kiroku's @DuplicateEvent@ carries 'Just' the colliding id only when-PostgreSQL's detail string parses ('Nothing' otherwise), and because the-store's event-id uniqueness is global, even a matching id does not prove the-event landed in our stream. A mismatched id is never ours; a matching or-missing id is confirmed against the target stream with a point lookup. Callers-fold 'True' into their duplicate result and surface 'False' as the original-failure.--}-confirmBenignDuplicate ::-    (Store :> es) =>-    StoreTypes.StreamName ->-    EventId ->-    CommandError ->-    Eff es Bool-confirmBenignDuplicate streamName ourId = \case-    StoreFailed (DuplicateEvent (Just duplicateId))-        | duplicateId == ourId -> eventExistsInStream streamName ourId-    StoreFailed (DuplicateEvent Nothing) -> eventExistsInStream streamName ourId-    _ -> pure False+-- | Stateful coordination across aggregates: the process manager (saga).+--+-- A 'ProcessManager' reacts to an incoming event by stepping its /own/ state+-- machine — a private \"manager\" event stream, keyed by a correlation id — and,+-- in the same turn, dispatching commands to /target/ aggregates and scheduling+-- timers. It is the stateful counterpart of "Keiro.Router": where a router+-- resolves targets from a read model and holds no state, a process manager+-- folds the events it has seen into durable manager state and decides what to+-- do next from that state.+--+-- Every write — the manager-state append, each dispatched command, each timer+-- — is keyed by a 'deterministicCommandId' derived from+-- @(name, correlation, source event id, emit index)@. The manager pre-checks+-- each id with 'eventAlreadyIn' and folds the store's duplicate rejection into+-- a benign 'PMCommandDuplicate' \/ 'PMStateDuplicate'. Replaying the same+-- source event therefore appends nothing new, which is what makes the worker+-- crash-safe under at-least-once delivery.+--+-- Use 'runProcessManagerOnce' to react to a single event, or+-- 'runProcessManagerWorker' to run the manager as a live subscription over a+-- Shibuya adapter. Worker acks are finalized exactly once: successful and duplicate+-- dispatches ack 'AckOk', transient store failures retry, systemic deterministic+-- failures halt, rejection-class failures follow 'RejectedCommandPolicy', and+-- undecodable messages follow the configured 'PoisonPolicy'.+--+-- === Rejected commands and saga history+--+-- 'RejectedHalt' is the safe default: the subscription stops without advancing,+-- so an operator cannot miss the failure. 'RejectedDeadLetter' instead writes a+-- durable "Keiro.DeadLetter.DispatchDeadLetter" and acknowledges the source+-- event; 'RejectedSkip' acknowledges and records only the metric. Prefer making a+-- target command total in its Keiki transducer (for example, an explicit no-op+-- transition for a benign business rejection) so no policy escape hatch is+-- needed.+--+-- For a process manager, dead-lettering a target dispatch creates an important+-- history split: the manager's own state stream has recorded its reaction, but+-- the target command never applied. Keiro cannot append a generic correction to+-- the manager stream because an event unknown to the manager's transducer would+-- make that stream fail replay. If saga history must reflect the failure, model a+-- domain-specific @DispatchFailed@-style command and event in the manager and+-- drive it from 'Keiro.DeadLetter.listDispatchDeadLetters' through an operator+-- runbook or automation. Otherwise, the dead-letter row is the durable witness.+-- Manager-state rejection itself has no such split because no manager event was+-- appended; its record uses emit index @-1@.+--+-- === Bounded retries and source-event dead letters+--+-- On a Kiroku-backed Shibuya adapter, a transient failure finalizes 'AckRetry',+-- but retries are bounded by the Kiroku subscription's @RetryPolicy@. Its+-- @retryMaxAttempts@ counts total deliveries and defaults to five. When the bound+-- is exhausted, Kiroku records the /source event/ in @kiroku.dead_letters@ with+-- structured reason kind @max_attempts_exceeded@ and atomically advances the+-- checkpoint. The manager will not see that event again unless an operator+-- replays it through @Keiro.DeadLetter.Replay@. Install+-- 'Keiro.Telemetry.kirokuEventBridge' on Kiroku's @eventHandler@ to observe the+-- terminal transition.+--+-- The adapter's @KirokuAdapterConfig@ does not currently expose @retryPolicy@, so+-- that path uses Kiroku's default bound. The sharded path is configurable:+-- 'Keiro.Subscription.Shard.Worker.runShardedSubscriptionGroupAck' forwards+-- 'Keiro.Subscription.Shard.Worker.ShardedWorkerOptions.retryPolicy' into the+-- same Kiroku acknowledgement ladder. A shard handler that dispatches commands+-- can use 'decideForFailures' and 'isRejectionClass' to classify outcomes, then+-- map the decision to its existing @ShardAck@ reply.+--+-- === Correlation, ordering, and transaction boundaries+--+-- Events from one originating stream retain that stream's append order. Kiroku+-- consumer groups hash the originating stream id to a stable member, so sharding+-- does not split one stream across readers. Events from /different/ streams that+-- 'correlate' to the same manager instance have no business-order guarantee,+-- however. Their append transactions race for global positions and, under+-- sharding, the streams may be processed concurrently by different members. A+-- retry on one member does not stop another member from advancing.+--+-- For example, both @payment-ORD1@'s @PaymentCaptured@ and @shipment-ORD1@'s+-- @ShipmentAllocated@ may correlate to order @ORD1@. The manager must accept+-- @PaymentCaptured@ then @ShipmentAllocated@ /and/ the reverse, normally with+-- states that record one fact while waiting for the other. An unsharded Kiroku+-- subscription processes its observed global order serially, including retries,+-- but that order still reflects append timing rather than a domain sequence.+--+-- Rule of thumb: 'correlate' may join streams freely, but every such join must be+-- order-insensitive. When a strict sequence is required, enforce it in the+-- manager's own state machine — for example with an explicit no-op/waiting state+-- and a timer-driven retry, or a modeled rejection handled by the dead-letter+-- policy — never by assuming delivery order.+--+-- The persistence boundary is also intentionally smaller than one whole saga+-- reaction. A manager event and its timers commit together when the manager+-- command appends; a timer-only no-op reaction schedules its timers in a separate+-- transaction. Each target command and its inline projections then commit in+-- their own transaction. A crash or rejected target can therefore leave durable+-- manager history without every target write. Deterministic ids make source-event+-- replay fill the missing writes without duplicating completed ones; the rejected+-- command section above describes the case that is deliberately acknowledged+-- instead.+module Keiro.ProcessManager+  ( -- * Definition+    ProcessManager (..),+    ProcessManagerAction (..),+    PMCommand (..),++    -- * Results+    ProcessManagerResult (..),+    PMCommandResult (..),+    PMStateResult (..),++    -- * Running+    PoisonPolicy (..),+    RejectedCommandPolicy (..),+    DispatchFailure (..),+    WorkerOptions (..),+    defaultWorkerOptions,+    isTransientStoreError,+    isTransientCommandError,+    isRejectionClass,+    decideForFailures,+    ackForCommandError,+    runProcessManagerOnce,+    runProcessManagerWorkerWith,+    runProcessManagerWorker,++    -- * Idempotency primitives+    deterministicCommandId,+    eventAlreadyIn,+    confirmBenignDuplicate,+  )+where++import Data.Coerce (coerce)+import Data.Text qualified as Text+import Data.UUID qualified as UUID+import Data.UUID.V5 qualified as UUID.V5+import Effectful (Eff, IOE, (:>))+import Effectful.Error.Static (Error, tryError)+import GHC.Stack (HasCallStack)+import Keiki.Core (BoolAlg, RegFile)+import Keiro.Command (CommandError (..), CommandResult, RunCommandOptions, commandErrorClass, runCommandWithSql)+import Keiro.DeadLetter (DispatchDeadLetter (..), DispatcherKind (..), recordDispatchDeadLetter)+import Keiro.EventStream (EventStream)+import Keiro.EventStream.Validate (ValidatedEventStream, unvalidated)+import Keiro.Prelude+import Keiro.Projection (InlineProjection, runCommandWithProjections)+import Keiro.Stream (Stream)+import Keiro.Telemetry (KeiroMetrics, recordDispatchDeadLettered, recordDispatchDuplicate, recordDispatchFailed, recordDispatchPoison)+import Keiro.Timer (TimerRequest, scheduleTimerTx)+import Kiroku.Store.Effect (Store)+import Kiroku.Store.Effect.Resource (KirokuStoreResource)+import Kiroku.Store.Error (StoreError (..))+import Kiroku.Store.Read (eventExistsInStream)+import Kiroku.Store.Transaction (runTransaction)+import Kiroku.Store.Types (EventId (..), RecordedEvent)+import Kiroku.Store.Types qualified as StoreTypes+import Shibuya.Adapter (Adapter (..))+import Shibuya.Core.Ack (AckDecision (..), DeadLetterReason (..), HaltReason (..), RetryDelay (..))+import Shibuya.Core.AckHandle (AckHandle (..))+import Shibuya.Core.Ingested (Ingested (..))+import Shibuya.Core.Types (Attempt (..), Envelope (..))+import Streamly.Data.Fold qualified as Fold+import Streamly.Data.Stream qualified as Streamly+import Prelude (any, filter, fromIntegral, length, not, uncurry, zip, (&&), (+))++-- | A process manager wiring together a manager state machine and the target+-- aggregate it drives.+--+-- * 'name' — stable identity; part of every deterministic write id.+-- * 'correlate' — derives the correlation key for an input event, selecting+--   which manager instance handles it.+-- * 'eventStream' — the manager's own 'EventStream'; its events record the+--   saga's progress.+-- * 'streamFor' — maps a correlation key to the manager's 'Stream' handle.+-- * 'targetEventStream' — the aggregate that dispatched commands are sent to.+-- * 'targetProjections' — inline projections for the target aggregate, run in+--   the same transaction as each dispatched command's append. Return @[]@ for+--   append-only dispatch.+-- * 'handle' — the pure reaction: given an input event, produce the+--   manager-state command, the target commands to dispatch, and any timers to+--   schedule.+data ProcessManager input phi rs s ci co targetPhi targetRs targetState targetCi targetCo = ProcessManager+  { name :: !Text,+    correlate :: !(input -> Text),+    eventStream :: !(ValidatedEventStream phi rs s ci co),+    streamFor :: !(Text -> Stream (EventStream phi rs s ci co)),+    targetEventStream :: !(ValidatedEventStream targetPhi targetRs targetState targetCi targetCo),+    -- | Inline projections for the target aggregate, run in the same transaction+    --     as each dispatched command's append. Return @[]@ for append-only dispatch.+    targetProjections :: !(Stream targetCi -> [InlineProjection targetCo]),+    handle :: !(input -> ProcessManagerAction ci targetCi)+  }+  deriving stock (Generic)++-- | What a process manager decides to do for one input event: advance its own+-- state with 'command', dispatch zero or more target 'commands', and schedule+-- zero or more 'timers'. All three are applied atomically with crash-safe+-- idempotency by 'runProcessManagerOnce'.+data ProcessManagerAction ci targetCi = ProcessManagerAction+  { command :: !ci,+    commands :: ![PMCommand targetCi],+    timers :: ![TimerRequest]+  }+  deriving stock (Generic)++-- | A single command addressed to a specific target stream.+data PMCommand targetCi = PMCommand+  { target :: !(Stream targetCi),+    command :: !targetCi+  }+  deriving stock (Generic, Eq, Show)++-- | Outcome of one dispatched target command.+data PMCommandResult target+  = -- | The command appended events (carries the 'CommandResult').+    PMCommandAppended !(CommandResult target)+  | -- | The command was already applied (idempotent replay); carries the+    --       deterministic id that already existed.+    PMCommandDuplicate !EventId+  | -- | The command failed in the named target stream; the worker classifies+    --       the error. Transient failures retry, rejection-class failures follow+    --       'RejectedCommandPolicy', and systemic deterministic failures halt.+    PMCommandFailed !StoreTypes.StreamName !CommandError+  deriving stock (Generic, Eq, Show)++-- | Outcome of the manager's own state append. Unlike 'PMCommandResult' there+-- is no failure case — a manager-state append that genuinely errors aborts the+-- whole reaction via an outer @Left@ 'CommandError'.+data PMStateResult target+  = PMStateAppended !(CommandResult target)+  | PMStateDuplicate !EventId+  deriving stock (Generic, Eq, Show)++-- | The complete result of reacting to one event: how the manager state+-- advanced, the outcome of each dispatched command in order, and how many+-- timers were scheduled.+data ProcessManagerResult managerTarget commandTarget = ProcessManagerResult+  { managerResult :: !(PMStateResult managerTarget),+    commandResults :: ![PMCommandResult commandTarget],+    timersScheduled :: !Int+  }+  deriving stock (Generic, Eq, Show)++-- | What a worker does with a message its decoder cannot parse.+data PoisonPolicy es msg+  = PoisonHalt+  | PoisonSkip !(Envelope msg -> Eff es ())+  | PoisonDeadLetter !(Envelope msg -> Eff es ())++-- | What a worker does when every failed dispatch is a rejection-class error.+data RejectedCommandPolicy+  = -- | Halt without acknowledging so the source event replays. This is the default.+    RejectedHalt+  | -- | Persist a durable dispatch dead letter and acknowledge the source event.+    RejectedDeadLetter+  | -- | Acknowledge and count the rejection without persisting a record.+    RejectedSkip+  deriving stock (Generic, Eq, Show)++-- | One failed dispatch with the target identity needed by worker policy.+data DispatchFailure = DispatchFailure+  { emitIndex :: !Int,+    targetStreamName :: !StoreTypes.StreamName,+    commandError :: !CommandError+  }+  deriving stock (Generic, Eq, Show)++-- | Worker-level knobs shared by the process-manager and router workers.+data WorkerOptions es msg = WorkerOptions+  { poisonPolicy :: !(PoisonPolicy es msg),+    rejectedCommandPolicy :: !RejectedCommandPolicy,+    transientRetryDelay :: !RetryDelay,+    metrics :: !(Maybe KeiroMetrics)+  }+  deriving stock (Generic)++defaultWorkerOptions :: WorkerOptions es msg+defaultWorkerOptions =+  WorkerOptions+    { poisonPolicy = PoisonHalt,+      rejectedCommandPolicy = RejectedHalt,+      transientRetryDelay = RetryDelay 5,+      metrics = Nothing+    }++isTransientStoreError :: StoreError -> Bool+isTransientStoreError = \case+  ConnectionLost {} -> True+  PoolAcquisitionTimeout -> True+  ConnectionError {} -> True+  WrongExpectedVersion {} -> True+  StreamAlreadyExists {} -> True+  EmptyAppendBatch {} -> False+  StreamNotFound {} -> False+  ReservedStreamName {} -> False+  StreamNameTooLong {} -> False+  DuplicateEvent {} -> False+  EventAlreadyLinked {} -> False+  LinkSourceEventMissing {} -> False+  UnexpectedServerError {} -> False++isTransientCommandError :: CommandError -> Bool+isTransientCommandError = \case+  StoreFailed err -> isTransientStoreError err+  RetryExhausted _ err -> isTransientStoreError err+  ConflictFixpoint _ err -> isTransientStoreError err+  HydrationDecodeFailed {} -> False+  HydrationReplayFailed {} -> False+  HydrationGapDetected {} -> False+  CommandRejected -> False+  CommandAmbiguous {} -> False+  EncodeFailed {} -> False++-- | Whether a command error is a per-command rejection covered by worker policy.+isRejectionClass :: CommandError -> Bool+isRejectionClass = \case+  CommandRejected -> True+  CommandAmbiguous {} -> True+  _ -> False++-- | Classify a group of failed dispatches and choose one acknowledgement.+--+-- Systemic deterministic errors always halt. Any transient error retries the+-- whole source event. Only an all-rejection group reaches the configured+-- 'RejectedCommandPolicy'. Dead-letter writes are idempotent under redelivery.+decideForFailures ::+  (IOE :> es, Store :> es) =>+  WorkerOptions es msg ->+  DispatcherKind ->+  Text ->+  Text ->+  RecordedEvent ->+  Int ->+  [DispatchFailure] ->+  Eff es AckDecision+decideForFailures workerOptions dispatcherKind dispatcherName correlationId sourceEvent attemptCount failures =+  case filter isSystemicDeterministic failures of+    failure : _ -> pure (haltFor failure)+    []+      | any (isTransientCommandError . (^. #commandError)) failures ->+          pure (AckRetry (workerOptions ^. #transientRetryDelay))+      | otherwise ->+          case failures of+            [] -> pure AckOk+            _ -> decideRejected+  where+    isSystemicDeterministic failure =+      let err = failure ^. #commandError+       in not (isTransientCommandError err) && not (isRejectionClass err)++    haltFor failure =+      AckHalt (HaltFatal (Text.pack (show (failure ^. #commandError))))++    decideRejected =+      case workerOptions ^. #rejectedCommandPolicy of+        RejectedHalt -> pure (haltFor (headFailure failures))+        RejectedDeadLetter -> do+          traverse_ recordFailure failures+          recordHandled+          pure AckOk+        RejectedSkip -> do+          recordHandled+          pure AckOk++    recordHandled =+      recordDispatchDeadLettered+        (workerOptions ^. #metrics)+        (fromIntegral (length failures))++    recordFailure failure =+      let err = failure ^. #commandError+       in recordDispatchDeadLetter+            DispatchDeadLetter+              { dispatcherKind = dispatcherKind,+                dispatcherName = dispatcherName,+                correlationId = correlationId,+                sourceEventId = sourceEvent ^. #eventId,+                sourceGlobalPosition = sourceEvent ^. #globalPosition,+                emitIndex = failure ^. #emitIndex,+                targetStreamName = failure ^. #targetStreamName,+                errorClass = commandErrorClass err,+                errorDetail = Text.pack (show err),+                attemptCount = max 1 attemptCount+              }++    headFailure = \case+      failure : _ -> failure+      [] -> DispatchFailure (-1) (StoreTypes.StreamName "unknown") CommandRejected++ackForCommandError :: RetryDelay -> CommandError -> AckDecision+ackForCommandError delay err+  | isTransientCommandError err = AckRetry delay+  | otherwise = AckHalt (HaltFatal (Text.pack (show err)))++-- | Derive a stable, collision-resistant 'EventId' for a manager write from+-- @(manager name, correlation id, source event id, emit index)@ via a v5 UUID.+--+-- The same inputs always yield the same id, so a replayed source event+-- produces the same write ids and the store's uniqueness constraint collapses+-- the duplicate. The manager-state append uses an emit index of @-1@ to keep+-- it distinct from the dispatched commands (which start at @0@). This positional+-- index is sound because 'handle' is pure and therefore returns the same command+-- order for the same input. The effectful router uses+-- 'Keiro.Router.deterministicRouterCommandId' instead, retaining this positional+-- id only as a transition probe for pre-upgrade router dispatches.+deterministicCommandId :: Text -> Text -> EventId -> Int -> EventId+deterministicCommandId managerName correlationId sourceEventId emitIndex =+  EventId+    $ UUID.V5.generateNamed UUID.V5.namespaceURL+    $ fmap (fromIntegral . fromEnum)+    $ Text.unpack+    $ Text.intercalate+      ":"+      [ "keiro",+        "process-manager",+        managerName,+        correlationId,+        UUID.toText (eventIdToUuid sourceEventId),+        Text.pack (show emitIndex)+      ]++-- | React to a single source event: advance the manager's state, dispatch+-- its target commands, and schedule its timers — each under a deterministic,+-- idempotent write id.+--+-- The manager-state append and its timers commit in one transaction; each+-- target command is then dispatched (with its inline projections) in its own.+-- A duplicate manager append short-circuits to 'PMStateDuplicate' but still+-- re-runs the dispatch loop, so a crash between the state append and a+-- command dispatch is recovered on replay. Returns @Left@ only when the+-- manager-state append fails for a non-duplicate reason; per-command failures+-- are reported inside 'commandResults'.+runProcessManagerOnce ::+  forall input phi rs s ci co targetPhi targetRs targetState targetCi targetCo es.+  ( HasCallStack,+    IOE :> es,+    Store :> es,+    Error StoreError :> es,+    KirokuStoreResource :> es,+    BoolAlg phi (RegFile rs, ci),+    BoolAlg targetPhi (RegFile targetRs, targetCi),+    Eq co,+    Eq targetCo+  ) =>+  RunCommandOptions ->+  ProcessManager input phi rs s ci co targetPhi targetRs targetState targetCi targetCo ->+  RecordedEvent ->+  input ->+  Eff es (Either CommandError (ProcessManagerResult (EventStream phi rs s ci co) (EventStream targetPhi targetRs targetState targetCi targetCo)))+runProcessManagerOnce options manager sourceEvent input = do+  let correlationId = (manager ^. #correlate) input+      action = (manager ^. #handle) input+      managerStream = (manager ^. #streamFor) correlationId+      managerEventId = deterministicCommandId (manager ^. #name) correlationId (sourceEvent ^. #eventId) (-1)+      managerOptions = options & #eventIds .~ [managerEventId]+      managerStreamName = ((unvalidated (manager ^. #eventStream)) ^. #resolveStreamName) managerStream+  managerAlreadyProcessed <- eventAlreadyIn options managerStreamName managerEventId+  if managerAlreadyProcessed+    then finish correlationId (PMStateDuplicate managerEventId) action+    else do+      managerOutcome <-+        runCommandWithSql+          managerOptions+          (manager ^. #eventStream)+          managerStream+          (action ^. #command)+          (\_ -> traverse_ scheduleTimerTx (action ^. #timers))+      case managerOutcome of+        Left err -> do+          benign <- confirmBenignDuplicate managerStreamName managerEventId err+          if benign+            then finish correlationId (PMStateDuplicate managerEventId) action+            else pure (Left err)+        Right (managerResult, scheduledInAppend) -> do+          -- No-op manager commands do not execute runCommandWithSql's callback,+          -- so schedule timer-only reactions explicitly.+          case scheduledInAppend of+            Nothing -> runTransaction (traverse_ scheduleTimerTx (action ^. #timers))+            Just () -> pure ()+          finish correlationId (PMStateAppended managerResult) action+  where+    finish correlationId managerResult action = do+      commandResults <- dispatchCommands correlationId (sourceEvent ^. #eventId) (action ^. #commands)+      pure+        $ Right+          ProcessManagerResult+            { managerResult = managerResult,+              commandResults = commandResults,+              timersScheduled = length (action ^. #timers)+            }++    dispatchCommands correlationId sourceEventId commands =+      traverse+        (uncurry (dispatchCommand correlationId sourceEventId))+        (zip [0 ..] commands)++    dispatchCommand correlationId sourceEventId emitIndex command = do+      let commandId = deterministicCommandId (manager ^. #name) correlationId sourceEventId emitIndex+          targetOptions = options & #eventIds .~ [commandId]+          targetStream = retarget (command ^. #target)+          targetStreamName = ((unvalidated (manager ^. #targetEventStream)) ^. #resolveStreamName) targetStream+      commandAlreadyProcessed <- eventAlreadyIn options targetStreamName commandId+      if commandAlreadyProcessed+        then pure (PMCommandDuplicate commandId)+        else do+          outcome <-+            runCommandWithProjections+              targetOptions+              (manager ^. #targetEventStream)+              targetStream+              (command ^. #command)+              ((manager ^. #targetProjections) (command ^. #target))+          case outcome of+            Right result -> pure (PMCommandAppended result)+            Left err -> do+              benign <- confirmBenignDuplicate targetStreamName commandId err+              pure $ if benign then PMCommandDuplicate commandId else PMCommandFailed targetStreamName err++    retarget :: Stream targetCi -> Stream (EventStream targetPhi targetRs targetState targetCi targetCo)+    retarget = coerce++-- | Run a process manager as a live subscription draining a Shibuya adapter with+-- 'defaultWorkerOptions'.+--+-- Use 'runProcessManagerWorkerWith' to override poison-message handling, rejected+-- command handling, transient retry delay, or dispatch metrics. Every ingested message's ack handle is+-- finalized exactly once. Successful and duplicate dispatches finalize 'AckOk';+-- transient store failures finalize 'AckRetry'; rejection-class failures follow+-- 'RejectedCommandPolicy'; other deterministic failures finalize 'AckHalt';+-- undecodable messages follow the configured 'PoisonPolicy'. Under+-- 'RejectedDeadLetter', see the module-level saga-history contract before opting+-- in. On a Kiroku-backed adapter, each 'AckRetry' redelivery is bounded by the+-- subscription @RetryPolicy@ (five total deliveries by default). Exhaustion+-- dead-letters the source event in @kiroku.dead_letters@ and advances the+-- checkpoint; @KirokuAdapterConfig@ does not currently expose that bound. Observe+-- the terminal event with 'Keiro.Telemetry.kirokuEventBridge' and replay it with+-- @Keiro.DeadLetter.Replay@ when appropriate.+runProcessManagerWorker ::+  forall msg input phi rs s ci co targetPhi targetRs targetState targetCi targetCo es.+  ( HasCallStack,+    IOE :> es,+    Store :> es,+    Error StoreError :> es,+    KirokuStoreResource :> es,+    BoolAlg phi (RegFile rs, ci),+    BoolAlg targetPhi (RegFile targetRs, targetCi),+    Eq co,+    Eq targetCo+  ) =>+  RunCommandOptions ->+  ProcessManager input phi rs s ci co targetPhi targetRs targetState targetCi targetCo ->+  Adapter es msg ->+  (msg -> Maybe (RecordedEvent, input)) ->+  Eff es ()+runProcessManagerWorker =+  runProcessManagerWorkerWith defaultWorkerOptions++runProcessManagerWorkerWith ::+  forall msg input phi rs s ci co targetPhi targetRs targetState targetCi targetCo es.+  ( HasCallStack,+    IOE :> es,+    Store :> es,+    Error StoreError :> es,+    KirokuStoreResource :> es,+    BoolAlg phi (RegFile rs, ci),+    BoolAlg targetPhi (RegFile targetRs, targetCi),+    Eq co,+    Eq targetCo+  ) =>+  WorkerOptions es msg ->+  RunCommandOptions ->+  ProcessManager input phi rs s ci co targetPhi targetRs targetState targetCi targetCo ->+  Adapter es msg ->+  (msg -> Maybe (RecordedEvent, input)) ->+  Eff es ()+runProcessManagerWorkerWith workerOptions options manager Adapter {source = adapterSource} decodeMessage =+  Streamly.fold Fold.drain+    $ Streamly.mapM handleIngested adapterSource+  where+    handleIngested :: Ingested es msg -> Eff es AckDecision+    handleIngested Ingested {envelope = env@Envelope {payload = message}, ack = AckHandle finalizeAck} = do+      decision <- case decodeMessage message of+        Nothing -> decideForPoison workerOptions "process-manager worker could not decode message" env+        Just (recorded, input) -> do+          let correlationId = (manager ^. #correlate) input+              managerStream = (manager ^. #streamFor) correlationId+              managerStreamName = ((unvalidated (manager ^. #eventStream)) ^. #resolveStreamName) managerStream+              attemptCount = envelopeAttemptCount env+          outcome <- tryError @StoreError (runProcessManagerOnce options manager recorded input)+          case outcome of+            Left (_, storeErr) -> do+              recordDispatchFailed (workerOptions ^. #metrics) 1+              pure (ackForThrownStoreError (workerOptions ^. #transientRetryDelay) storeErr)+            Right (Left err) -> do+              recordDispatchFailed (workerOptions ^. #metrics) 1+              decideForFailures+                workerOptions+                DispatcherProcessManager+                (manager ^. #name)+                correlationId+                recorded+                attemptCount+                [DispatchFailure (-1) managerStreamName err]+            Right (Right result) ->+              ackForResults+                workerOptions+                (manager ^. #name)+                correlationId+                recorded+                attemptCount+                (result ^. #managerResult)+                (result ^. #commandResults)+      finalizeAck decision+      pure decision++ackForThrownStoreError :: RetryDelay -> StoreError -> AckDecision+ackForThrownStoreError delay = ackForCommandError delay . StoreFailed++ackForResults ::+  (IOE :> es, Store :> es) =>+  WorkerOptions es msg ->+  Text ->+  Text ->+  RecordedEvent ->+  Int ->+  PMStateResult managerTarget ->+  [PMCommandResult commandTarget] ->+  Eff es AckDecision+ackForResults workerOptions managerName correlationId sourceEvent attemptCount managerResult commandResults = do+  let duplicateCount = stateDuplicateCount managerResult + commandDuplicateCount commandResults+      failures =+        [ DispatchFailure emitIndex targetStreamName err+        | (emitIndex, PMCommandFailed targetStreamName err) <- zip [0 ..] commandResults+        ]+  recordDispatchDuplicate (workerOptions ^. #metrics) duplicateCount+  recordDispatchFailed (workerOptions ^. #metrics) (fromIntegral (length failures))+  decideForFailures+    workerOptions+    DispatcherProcessManager+    managerName+    correlationId+    sourceEvent+    attemptCount+    failures++stateDuplicateCount :: PMStateResult target -> Int64+stateDuplicateCount = \case+  PMStateDuplicate {} -> 1+  PMStateAppended {} -> 0++commandDuplicateCount :: [PMCommandResult target] -> Int64+commandDuplicateCount =+  fromIntegral . length . filter isDuplicateResult+  where+    isDuplicateResult = \case+      PMCommandDuplicate {} -> True+      _ -> False++envelopeAttemptCount :: Envelope msg -> Int+envelopeAttemptCount env =+  case env ^. #attempt of+    Nothing -> 1+    Just (Attempt attempt) -> fromIntegral attempt + 1++decideForPoison ::+  (IOE :> es) =>+  WorkerOptions es msg ->+  Text ->+  Envelope msg ->+  Eff es AckDecision+decideForPoison workerOptions reason env = do+  recordDispatchPoison (workerOptions ^. #metrics) 1+  case workerOptions ^. #poisonPolicy of+    PoisonHalt -> pure (AckHalt (HaltFatal reason))+    PoisonSkip callback -> do+      callback env+      pure AckOk+    PoisonDeadLetter callback -> do+      callback env+      pure (AckDeadLetter (InvalidPayload reason))++eventIdToUuid :: EventId -> UUID.UUID+eventIdToUuid (EventId uuid) = uuid++-- | Check whether an event with the given id is already present in a live stream.+-- Used as the pre-dispatch idempotency guard so a+-- command that was already applied on a prior (possibly crashed) attempt is+-- recognized as a duplicate before re-running it.+eventAlreadyIn ::+  (Store :> es) =>+  RunCommandOptions ->+  StoreTypes.StreamName ->+  EventId ->+  Eff es Bool+eventAlreadyIn _options streamName eventId =+  eventExistsInStream streamName eventId++-- | Decide whether a failed append is a benign duplicate of the write just+-- attempted: whether @ourId@ is genuinely present in @streamName@.+--+-- Kiroku's @DuplicateEvent@ carries 'Just' the colliding id only when+-- PostgreSQL's detail string parses ('Nothing' otherwise), and because the+-- store's event-id uniqueness is global, even a matching id does not prove the+-- event landed in our stream. A mismatched id is never ours; a matching or+-- missing id is confirmed against the target stream with a point lookup. Callers+-- fold 'True' into their duplicate result and surface 'False' as the original+-- failure.+confirmBenignDuplicate ::+  (Store :> es) =>+  StoreTypes.StreamName ->+  EventId ->+  CommandError ->+  Eff es Bool+confirmBenignDuplicate streamName ourId = \case+  StoreFailed (DuplicateEvent (Just duplicateId))+    | duplicateId == ourId -> eventExistsInStream streamName ourId+  StoreFailed (DuplicateEvent Nothing) -> eventExistsInStream streamName ourId+  _ -> pure False
src/Keiro/Projection.hs view
@@ -1,24 +1,23 @@-{- | Projections: turning a stream's events into read-side state.--Two flavors, trading consistency against coupling:--* An 'InlineProjection' runs in the /same/ transaction as the command that-  produced the events, so the read model is updated atomically with the-  append — never stale, but tied to the writer's transaction and latency.-  'runCommandWithProjections' runs a command and applies a list of inline-  projections to whatever it emits.-* An 'AsyncProjection' runs later from a subscription draining the event-  log. It carries a 'subscriptionName' for checkpointing and an-  'idempotencyKey' so redelivery is safe; 'applyAsyncProjection' performs-  one application. This decouples the read model from the writer at the-  cost of eventual consistency.--Both ultimately fold events into a SQL read model via a-'Hasql.Transaction.Transaction'; the difference is only /when/ that-transaction runs.--}-module Keiro.Projection (-    -- * Inline projections+-- | Projections: turning a stream's events into read-side state.+--+-- Two flavors, trading consistency against coupling:+--+-- * An 'InlineProjection' runs in the /same/ transaction as the command that+--   produced the events, so the read model is updated atomically with the+--   append — never stale, but tied to the writer's transaction and latency.+--   'runCommandWithProjections' runs a command and applies a list of inline+--   projections to whatever it emits.+-- * An 'AsyncProjection' runs later from a subscription draining the event+--   log. It carries a 'subscriptionName' for checkpointing and an+--   'idempotencyKey' so redelivery is safe; 'applyAsyncProjection' performs+--   one application. This decouples the read model from the writer at the+--   cost of eventual consistency.+--+-- Both ultimately fold events into a SQL read model via a+-- 'Hasql.Transaction.Transaction'; the difference is only /when/ that+-- transaction runs.+module Keiro.Projection+  ( -- * Inline projections     InlineProjection (..),     runCommandWithProjections, @@ -29,7 +28,7 @@     applyAsyncProjectionUnfenced,     pruneAsyncProjectionDedupBefore,     recordProjectionLag,-)+  ) where  import Contravariant.Extras (contrazip2)@@ -57,154 +56,147 @@ import "hasql-transaction" Hasql.Transaction qualified as Tx import Prelude qualified -{- | A read-model update applied synchronously with the command that emits-the event. 'apply' receives both the decoded event @co@ and the-'RecordedEvent' the store persisted, and runs in the append transaction.-'name' identifies the projection for diagnostics.--}+-- | A read-model update applied synchronously with the command that emits+-- the event. 'apply' receives both the decoded event @co@ and the+-- 'RecordedEvent' the store persisted, and runs in the append transaction.+-- 'name' identifies the projection for diagnostics. data InlineProjection co = InlineProjection-    { name :: !Text-    , apply :: !(co -> RecordedEvent -> Tx.Transaction ())-    }-    deriving stock (Generic)--{- | A read-model update applied asynchronously by a subscription worker.+  { name :: !Text,+    apply :: !(co -> RecordedEvent -> Tx.Transaction ())+  }+  deriving stock (Generic) -* 'name' — identifies the projection for diagnostics.-* 'readModelName' — names the registry row for the model this projection writes.-* 'subscriptionName' — the cursor under which the worker checkpoints its-  progress through the event log.-* 'applyRecorded' — folds one 'RecordedEvent' into the read model.-* 'idempotencyKey' — the 'EventId' used to suppress duplicate application on-  redelivery, making the projection safe to retry.--}+-- | A read-model update applied asynchronously by a subscription worker.+--+-- * 'name' — identifies the projection for diagnostics.+-- * 'readModelName' — names the registry row for the model this projection writes.+-- * 'subscriptionName' — the cursor under which the worker checkpoints its+--   progress through the event log.+-- * 'applyRecorded' — folds one 'RecordedEvent' into the read model.+-- * 'idempotencyKey' — the 'EventId' used to suppress duplicate application on+--   redelivery, making the projection safe to retry. data AsyncProjection = AsyncProjection-    { name :: !Text-    , readModelName :: !Text-    , subscriptionName :: !Text-    , applyRecorded :: !(RecordedEvent -> Tx.Transaction ())-    , idempotencyKey :: !(RecordedEvent -> EventId)-    }-    deriving stock (Generic)+  { name :: !Text,+    readModelName :: !Text,+    subscriptionName :: !Text,+    applyRecorded :: !(RecordedEvent -> Tx.Transaction ()),+    idempotencyKey :: !(RecordedEvent -> EventId)+  }+  deriving stock (Generic)  -- | The database-visible result of one asynchronous projection attempt. data AsyncApplyOutcome-    = AsyncApplied-    | AsyncDuplicate-    | AsyncFenced-    deriving stock (Generic, Eq, Show)+  = AsyncApplied+  | AsyncDuplicate+  | AsyncFenced+  deriving stock (Generic, Eq, Show) -{- | Run a command and apply every supplied 'InlineProjection' to the events-it emits, all inside the command's append transaction. A projection failure-aborts the whole transaction, so the events and the read-model update commit-together or not at all.--}+-- | Run a command and apply every supplied 'InlineProjection' to the events+-- it emits, all inside the command's append transaction. A projection failure+-- aborts the whole transaction, so the events and the read-model update commit+-- together or not at all. runCommandWithProjections ::-    forall phi rs s ci co es.-    (HasCallStack, IOE :> es, Store :> es, Error StoreError :> es, KirokuStoreResource :> es, BoolAlg phi (RegFile rs, ci), Eq co) =>-    RunCommandOptions ->-    ValidatedEventStream phi rs s ci co ->-    Stream (EventStream phi rs s ci co) ->-    ci ->-    [InlineProjection co] ->-    Eff es (Either CommandError (CommandResult (EventStream phi rs s ci co)))+  forall phi rs s ci co es.+  (HasCallStack, IOE :> es, Store :> es, Error StoreError :> es, KirokuStoreResource :> es, BoolAlg phi (RegFile rs, ci), Eq co) =>+  RunCommandOptions ->+  ValidatedEventStream phi rs s ci co ->+  Stream (EventStream phi rs s ci co) ->+  ci ->+  [InlineProjection co] ->+  Eff es (Either CommandError (CommandResult (EventStream phi rs s ci co))) runCommandWithProjections options eventStream targetStream command projections = do-    result <--        runCommandWithSqlEvents-            options-            eventStream-            targetStream-            command-            ( \pairs _appendResult ->+  result <-+    runCommandWithSqlEvents+      options+      eventStream+      targetStream+      command+      ( \pairs _appendResult ->+          traverse_+            ( \projection ->                 traverse_-                    ( \projection ->-                        traverse_-                            (\(event, recorded) -> (projection ^. #apply) event recorded)-                            pairs-                    )-                    projections+                  (\(event, recorded) -> (projection ^. #apply) event recorded)+                  pairs             )-    pure (fmap Prelude.fst result)--{- | Apply one event to a live 'AsyncProjection', returning a distinct outcome-for a successful application, a retained dedup key, or a rebuild fence.--The registry row is read with @FOR SHARE@ inside the same transaction as the-dedup insert and application. A missing row or any status other than @live@-returns 'AsyncFenced' without touching either table. A worker that receives-'AsyncFenced' must not checkpoint past the event: fail or park the delivery and-retry after promotion. Ack-coupled Kiroku delivery preserves the checkpoint-when its handler does not acknowledge success.+            projections+      )+  pure (fmap Prelude.fst result) -The projection's 'idempotencyKey' is inserted into @keiro_projection_dedup@-inside the same transaction as 'applyRecorded'. When that insert conflicts,-the event was already applied within the retained dedup window and the update-is skipped. Use 'pruneAsyncProjectionDedupBefore' only for events older than-the subscription system can redeliver; pruning intentionally re-opens those-events for application if they are replayed later.--}+-- | Apply one event to a live 'AsyncProjection', returning a distinct outcome+-- for a successful application, a retained dedup key, or a rebuild fence.+--+-- The registry row is read with @FOR SHARE@ inside the same transaction as the+-- dedup insert and application. A missing row or any status other than @live@+-- returns 'AsyncFenced' without touching either table. A worker that receives+-- 'AsyncFenced' must not checkpoint past the event: fail or park the delivery and+-- retry after promotion. Ack-coupled Kiroku delivery preserves the checkpoint+-- when its handler does not acknowledge success.+--+-- The projection's 'idempotencyKey' is inserted into @keiro_projection_dedup@+-- inside the same transaction as 'applyRecorded'. When that insert conflicts,+-- the event was already applied within the retained dedup window and the update+-- is skipped. Use 'pruneAsyncProjectionDedupBefore' only for events older than+-- the subscription system can redeliver; pruning intentionally re-opens those+-- events for application if they are replayed later. applyAsyncProjection :: AsyncProjection -> RecordedEvent -> Tx.Transaction AsyncApplyOutcome applyAsyncProjection projection recorded = do-    status <--        Tx.statement-            (projection ^. #readModelName)-            lockReadModelStatusStmt-    case status of-        Just "live" -> applyAsyncProjectionUnfenced projection recorded-        _ -> pure AsyncFenced--{- | Apply one event without consulting the read-model registry fence.+  status <-+    Tx.statement+      (projection ^. #readModelName)+      lockReadModelStatusStmt+  case status of+    Just "live" -> applyAsyncProjectionUnfenced projection recorded+    _ -> pure AsyncFenced -This is exclusively the rebuild replay entry point: it retains normal dedup-semantics while permitting the designated rebuilder to write while the model is-@rebuilding@. Live workers must use 'applyAsyncProjection'.--}+-- | Apply one event without consulting the read-model registry fence.+--+-- This is exclusively the rebuild replay entry point: it retains normal dedup+-- semantics while permitting the designated rebuilder to write while the model is+-- @rebuilding@. Live workers must use 'applyAsyncProjection'. applyAsyncProjectionUnfenced :: AsyncProjection -> RecordedEvent -> Tx.Transaction AsyncApplyOutcome applyAsyncProjectionUnfenced projection recorded = do-    inserted <--        Tx.statement-            (projection ^. #name, eventIdToUuid ((projection ^. #idempotencyKey) recorded))-            insertProjectionDedupStmt-    if inserted-        then do-            (projection ^. #applyRecorded) recorded-            pure AsyncApplied-        else pure AsyncDuplicate--{- | Age out async-projection dedup rows older than the supplied timestamp.+  inserted <-+    Tx.statement+      (projection ^. #name, eventIdToUuid ((projection ^. #idempotencyKey) recorded))+      insertProjectionDedupStmt+  if inserted+    then do+      (projection ^. #applyRecorded) recorded+      pure AsyncApplied+    else pure AsyncDuplicate -Use this only beyond the subscription system's redelivery window; pruning-re-opens those events for application. It is not a rebuild reset. Supported-rebuilds use 'Keiro.ReadModel.Rebuild.startRebuild', which atomically deletes-only the named projections' keys while fencing writers and resetting the model.-Returns the number of rows pruned.--}+-- | Age out async-projection dedup rows older than the supplied timestamp.+--+-- Use this only beyond the subscription system's redelivery window; pruning+-- re-opens those events for application. It is not a rebuild reset. Supported+-- rebuilds use 'Keiro.ReadModel.Rebuild.startRebuild', which atomically deletes+-- only the named projections' keys while fencing writers and resetting the model.+-- Returns the number of rows pruned. pruneAsyncProjectionDedupBefore :: (Store :> es) => UTCTime -> Eff es Int64 pruneAsyncProjectionDedupBefore cutoff =-    runTransaction-        $ Tx.statement cutoff pruneProjectionDedupBeforeStmt--{- | Record 'keiro.projection.lag' for one async projection: how many events its-subscription is behind the global log head, computed as the store head global-position minus the subscription's checkpoint position (clamped at 0). A no-op-when no metrics handle is supplied. Call once per drain pass, after applying the-batch, so the gauge reflects the backlog the worker has left to catch up on.+  runTransaction+    $ Tx.statement cutoff pruneProjectionDedupBeforeStmt -There is no in-library polling drain loop today (the application drives-'applyAsyncProjection' per event), so this is the entry point an application-calls to surface lag for a subscription.--}+-- | Record 'keiro.projection.lag' for one async projection: how many events its+-- subscription is behind the global log head, computed as the store head global+-- position minus the subscription's checkpoint position (clamped at 0). A no-op+-- when no metrics handle is supplied. Call once per drain pass, after applying the+-- batch, so the gauge reflects the backlog the worker has left to catch up on.+--+-- There is no in-library polling drain loop today (the application drives+-- 'applyAsyncProjection' per event), so this is the entry point an application+-- calls to surface lag for a subscription. recordProjectionLag ::-    (IOE :> es, Store :> es) =>-    Maybe KeiroMetrics ->-    AsyncProjection ->-    Eff es ()+  (IOE :> es, Store :> es) =>+  Maybe KeiroMetrics ->+  AsyncProjection ->+  Eff es () recordProjectionLag metrics projection = do-    headPos <- storeHeadPosition-    checkpoint <--        fromMaybe (GlobalPosition 0)-            <$> readSubscriptionPosition (projection ^. #subscriptionName)-    Telemetry.recordProjectionLag metrics (positionGap headPos checkpoint)+  headPos <- storeHeadPosition+  checkpoint <-+    fromMaybe (GlobalPosition 0)+      <$> readSubscriptionPosition (projection ^. #subscriptionName)+  Telemetry.recordProjectionLag metrics (positionGap headPos checkpoint)  -- | The non-negative gap between the log head and a checkpoint, in events. positionGap :: GlobalPosition -> GlobalPosition -> Int64@@ -212,39 +204,39 @@  insertProjectionDedupStmt :: Statement (Text, UUID) Bool insertProjectionDedupStmt =-    preparable-        """-        INSERT INTO keiro.keiro_projection_dedup (projection_name, event_id)-        VALUES ($1, $2)-        ON CONFLICT (projection_name, event_id) DO NOTHING-        """-        ( contrazip2-            (E.param (E.nonNullable E.text))-            (E.param (E.nonNullable E.uuid))-        )-        ((> 0) <$> D.rowsAffected)+  preparable+    """+    INSERT INTO keiro.keiro_projection_dedup (projection_name, event_id)+    VALUES ($1, $2)+    ON CONFLICT (projection_name, event_id) DO NOTHING+    """+    ( contrazip2+        (E.param (E.nonNullable E.text))+        (E.param (E.nonNullable E.uuid))+    )+    ((> 0) <$> D.rowsAffected)  lockReadModelStatusStmt :: Statement Text (Maybe Text) lockReadModelStatusStmt =-    preparable-        """-        SELECT status-        FROM keiro.keiro_read_models-        WHERE name = $1-        FOR SHARE-        """-        (E.param (E.nonNullable E.text))-        (D.rowMaybe (D.column (D.nonNullable D.text)))+  preparable+    """+    SELECT status+    FROM keiro.keiro_read_models+    WHERE name = $1+    FOR SHARE+    """+    (E.param (E.nonNullable E.text))+    (D.rowMaybe (D.column (D.nonNullable D.text)))  pruneProjectionDedupBeforeStmt :: Statement UTCTime Int64 pruneProjectionDedupBeforeStmt =-    preparable-        """-        DELETE FROM keiro.keiro_projection_dedup-        WHERE applied_at < $1-        """-        (E.param (E.nonNullable E.timestamptz))-        D.rowsAffected+  preparable+    """+    DELETE FROM keiro.keiro_projection_dedup+    WHERE applied_at < $1+    """+    (E.param (E.nonNullable E.timestamptz))+    D.rowsAffected  eventIdToUuid :: EventId -> UUID eventIdToUuid (EventId value) = value
src/Keiro/ReadModel.hs view
@@ -1,32 +1,31 @@-{- | Querying the read side, with explicit consistency.--A 'ReadModel' is a named, versioned SQL projection table plus the query that-reads it. Querying it does more than run SQL: 'runQuery' first verifies the-table's registered schema is current and 'Live' (rejecting a stale or-mid-rebuild model), then honours the requested 'ConsistencyMode' before-running the query in a transaction.--The consistency modes trade freshness against latency:--* 'Strong' — capture the store head position at query start and block until-  the model's subscription cursor reaches it.-* 'Eventual' — query immediately. Read-your-writes is the projection worker's-  responsibility under 'Eventual'.-* 'PositionWait' — block until the model's subscription has caught up to a-  target 'GlobalPosition' (typically the position returned by the command-  the caller just ran), giving read-your-writes against an asynchronous-  projection. 'waitFor' implements the polling loop and times out with-  'ReadModelWaitTimeout'.--Schema lifecycle (registration, status transitions) lives in-"Keiro.ReadModel.Schema", which is re-exported here.--Register each model once at projection startup with 'registerReadModel' before-serving queries. Queries fail with 'ReadModelUnregistered' when startup wiring-has not registered the model; they never create registry rows themselves.--}-module Keiro.ReadModel (-    -- * Definition+-- | Querying the read side, with explicit consistency.+--+-- A 'ReadModel' is a named, versioned SQL projection table plus the query that+-- reads it. Querying it does more than run SQL: 'runQuery' first verifies the+-- table's registered schema is current and 'Live' (rejecting a stale or+-- mid-rebuild model), then honours the requested 'ConsistencyMode' before+-- running the query in a transaction.+--+-- The consistency modes trade freshness against latency:+--+-- * 'Strong' — capture the store head position at query start and block until+--   the model's subscription cursor reaches it.+-- * 'Eventual' — query immediately. Read-your-writes is the projection worker's+--   responsibility under 'Eventual'.+-- * 'PositionWait' — block until the model's subscription has caught up to a+--   target 'GlobalPosition' (typically the position returned by the command+--   the caller just ran), giving read-your-writes against an asynchronous+--   projection. 'waitFor' implements the polling loop and times out with+--   'ReadModelWaitTimeout'.+--+-- Schema lifecycle (registration, status transitions) lives in+-- "Keiro.ReadModel.Schema", which is re-exported here.+--+-- Register each model once at projection startup with 'registerReadModel' before+-- serving queries. Queries fail with 'ReadModelUnregistered' when startup wiring+-- has not registered the model; they never create registry rows themselves.+module Keiro.ReadModel+  ( -- * Definition     ReadModel (..),     qualifiedTableName, @@ -49,7 +48,7 @@      -- * Schema lifecycle     module Keiro.ReadModel.Schema,-)+  ) where  import Control.Concurrent (threadDelay)@@ -70,297 +69,282 @@ import "hasql-transaction" Hasql.Transaction qualified as Tx import Prelude qualified -{- | A queryable read-side projection over a query input @q@ and result @r@.--* 'name' — logical identity, also the key in the @keiro_read_models@-  registry.-* 'tableName' — the underlying projection table.-* 'schema' — the PostgreSQL schema the read-model /data/ table lives in. The-  application qualifies its 'query' SQL against this schema (typically via-  'Keiro.Connection.qualifyTable' or 'qualifiedTableName'); Keiro does not-  rewrite 'query'. This is the application's data schema and is entirely-  separate from Keiro's own @keiro@ schema, where the @keiro_read_models@-  registry lives. It is deliberately not persisted (see 'ensureReadModel').-* 'subscriptionName' — the cursor that tracks how far the projection worker-  has consumed the event log; consulted by 'PositionWait'.-* 'version' \/ 'shapeHash' — schema identity; a query fails with-  'ReadModelStaleSchema' if the registered values diverge, forcing a rebuild.-* 'defaultConsistency' — the 'ConsistencyMode' used by 'runQuery'.-* 'strongScope' — the event-log head a 'Strong' query waits for.-* 'query' — the SQL read, as a 'Hasql.Transaction.Transaction'.--}+-- | A queryable read-side projection over a query input @q@ and result @r@.+--+-- * 'name' — logical identity, also the key in the @keiro_read_models@+--   registry.+-- * 'tableName' — the underlying projection table.+-- * 'schema' — the PostgreSQL schema the read-model /data/ table lives in. The+--   application qualifies its 'query' SQL against this schema (typically via+--   'Keiro.Connection.qualifyTable' or 'qualifiedTableName'); Keiro does not+--   rewrite 'query'. This is the application's data schema and is entirely+--   separate from Keiro's own @keiro@ schema, where the @keiro_read_models@+--   registry lives. It is deliberately not persisted (see 'ensureReadModel').+-- * 'subscriptionName' — the cursor that tracks how far the projection worker+--   has consumed the event log; consulted by 'PositionWait'.+-- * 'version' \/ 'shapeHash' — schema identity; a query fails with+--   'ReadModelStaleSchema' if the registered values diverge, forcing a rebuild.+-- * 'defaultConsistency' — the 'ConsistencyMode' used by 'runQuery'.+-- * 'strongScope' — the event-log head a 'Strong' query waits for.+-- * 'query' — the SQL read, as a 'Hasql.Transaction.Transaction'. data ReadModel q r = ReadModel-    { name :: !Text-    , tableName :: !Text-    , schema :: !Text-    , subscriptionName :: !Text-    , version :: !Int-    , shapeHash :: !Text-    , defaultConsistency :: !ConsistencyMode-    , strongScope :: !StrongScope-    , query :: !(q -> Tx.Transaction r)-    }-    deriving stock (Generic)+  { name :: !Text,+    tableName :: !Text,+    schema :: !Text,+    subscriptionName :: !Text,+    version :: !Int,+    shapeHash :: !Text,+    defaultConsistency :: !ConsistencyMode,+    strongScope :: !StrongScope,+    query :: !(q -> Tx.Transaction r)+  }+  deriving stock (Generic) -{- | The read model's fully-qualified, double-quoted table reference-@"schema"."table"@, for interpolation into the application's projection SQL.-Equal to @'Keiro.Connection.qualifyTable' ('schema' rm) ('tableName' rm)@.--}+-- | The read model's fully-qualified, double-quoted table reference+-- @"schema"."table"@, for interpolation into the application's projection SQL.+-- Equal to @'Keiro.Connection.qualifyTable' ('schema' rm) ('tableName' rm)@. qualifiedTableName :: ReadModel q r -> Text qualifiedTableName readModel =-    qualifyTable (readModel ^. #schema) (readModel ^. #tableName)--{- | How fresh a read must be before the query runs.+  qualifyTable (readModel ^. #schema) (readModel ^. #tableName) -'Strong' waits for the model's subscription to reach the store head captured-at query start according to the model's 'strongScope'. It is intended for-asynchronous read models with a worker advancing that subscription cursor;-inline-only models should use 'Eventual' because they have no subscription-worker to advance while waiting.-'PositionWait' blocks until the projection has caught up to a caller-supplied-target log position (or times out). 'Eventual' queries immediately.--}+-- | How fresh a read must be before the query runs.+--+-- 'Strong' waits for the model's subscription to reach the store head captured+-- at query start according to the model's 'strongScope'. It is intended for+-- asynchronous read models with a worker advancing that subscription cursor;+-- inline-only models should use 'Eventual' because they have no subscription+-- worker to advance while waiting.+-- 'PositionWait' blocks until the projection has caught up to a caller-supplied+-- target log position (or times out). 'Eventual' queries immediately. data ConsistencyMode-    = Strong-    | Eventual-    | PositionWait !PositionWaitOptions-    deriving stock (Generic, Eq, Show)--{- | Which log head a 'Strong' read must reach.--'EntireLog' preserves the original behavior and is live only when the model's-subscription observes every event. A category subscription should use-'CategoryHead' with its Kiroku category, so unrelated categories cannot hold-the read behind forever. A model fed by multiple categories should use-'PositionWait' for an explicit write position or 'EntireLog' with a matching-all-stream subscription.+  = Strong+  | Eventual+  | PositionWait !PositionWaitOptions+  deriving stock (Generic, Eq, Show) -Kiroku currently does not advance category checkpoints on empty fetches. If it-does so in a future release, category-scoped targets may become unnecessary,-but the explicit model contract remains valid.--}+-- | Which log head a 'Strong' read must reach.+--+-- 'EntireLog' preserves the original behavior and is live only when the model's+-- subscription observes every event. A category subscription should use+-- 'CategoryHead' with its Kiroku category, so unrelated categories cannot hold+-- the read behind forever. A model fed by multiple categories should use+-- 'PositionWait' for an explicit write position or 'EntireLog' with a matching+-- all-stream subscription.+--+-- Kiroku currently does not advance category checkpoints on empty fetches. If it+-- does so in a future release, category-scoped targets may become unnecessary,+-- but the explicit model contract remains valid. data StrongScope-    = EntireLog-    | CategoryHead !Text-    deriving stock (Generic, Eq, Show)--{- | Parameters for a 'PositionWait' query.+  = EntireLog+  | CategoryHead !Text+  deriving stock (Generic, Eq, Show) -* 'target' — the 'GlobalPosition' the projection must reach; 'Nothing'-  skips waiting entirely.-* 'timeoutMicros' — give up after this long with 'ReadModelWaitTimeout'.-* 'pollMicros' — delay between subscription-position checks.--}+-- | Parameters for a 'PositionWait' query.+--+-- * 'target' — the 'GlobalPosition' the projection must reach; 'Nothing'+--   skips waiting entirely.+-- * 'timeoutMicros' — give up after this long with 'ReadModelWaitTimeout'.+-- * 'pollMicros' — delay between subscription-position checks. data PositionWaitOptions = PositionWaitOptions-    { target :: !(Maybe GlobalPosition)-    , timeoutMicros :: !Int-    , pollMicros :: !Int-    }-    deriving stock (Generic, Eq, Show)+  { target :: !(Maybe GlobalPosition),+    timeoutMicros :: !Int,+    pollMicros :: !Int+  }+  deriving stock (Generic, Eq, Show) -{- | Default wait settings used by 'Strong': wait up to five seconds, polling-every 10ms, for the store head captured at query start.--}+-- | Default wait settings used by 'Strong': wait up to five seconds, polling+-- every 10ms, for the store head captured at query start. defaultStrongWaitOptions :: PositionWaitOptions defaultStrongWaitOptions =-    PositionWaitOptions-        { target = Nothing-        , timeoutMicros = 5000000-        , pollMicros = 10000-        }+  PositionWaitOptions+    { target = Nothing,+      timeoutMicros = 5000000,+      pollMicros = 10000+    }  -- | Why a read-model query could not run. data ReadModelError-    = {- | No registry row exists for the model. Register it once at projection-      startup with 'registerReadModel' before serving queries.-      -}-      ReadModelUnregistered !Text-    | {- | The registered schema (version or shape hash) differs from the-      model's current definition: name, expected vs. found version, then-      expected vs. found shape hash. The model must be rebuilt.-      -}-      ReadModelStaleSchema !Text !Int !Int !Text !Text-    | {- | A 'PositionWait' query timed out: model name, target position, and-      the last observed subscription position.-      -}-      ReadModelWaitTimeout !Text !GlobalPosition !GlobalPosition-    | {- | The model is registered but not 'Live' (e.g. rebuilding or-      abandoned): name and current status.-      -}-      ReadModelNotLive !Text !ReadModelStatus-    deriving stock (Generic, Eq, Show)+  = -- | No registry row exists for the model. Register it once at projection+    --       startup with 'registerReadModel' before serving queries.+    ReadModelUnregistered !Text+  | -- | The registered schema (version or shape hash) differs from the+    --       model's current definition: name, expected vs. found version, then+    --       expected vs. found shape hash. The model must be rebuilt.+    ReadModelStaleSchema !Text !Int !Int !Text !Text+  | -- | A 'PositionWait' query timed out: model name, target position, and+    --       the last observed subscription position.+    ReadModelWaitTimeout !Text !GlobalPosition !GlobalPosition+  | -- | The model is registered but not 'Live' (e.g. rebuilding or+    --       abandoned): name and current status.+    ReadModelNotLive !Text !ReadModelStatus+  deriving stock (Generic, Eq, Show) -{- | Query a read model using its 'defaultConsistency'. Validates schema and-liveness first, waits if the mode requires it, then runs the query.--}+-- | Query a read model using its 'defaultConsistency'. Validates schema and+-- liveness first, waits if the mode requires it, then runs the query. runQuery ::-    (IOE :> es, Store :> es) =>-    Maybe KeiroMetrics ->-    ReadModel q r ->-    q ->-    Eff es (Either ReadModelError r)+  (IOE :> es, Store :> es) =>+  Maybe KeiroMetrics ->+  ReadModel q r ->+  q ->+  Eff es (Either ReadModelError r) runQuery metrics readModel =-    runQueryWith metrics (readModel ^. #defaultConsistency) readModel+  runQueryWith metrics (readModel ^. #defaultConsistency) readModel -{- | Query a read model with an explicit 'ConsistencyMode', overriding its-default. Validates the model's schema and liveness, honours the wait mode,-then runs the query in a transaction.--}+-- | Query a read model with an explicit 'ConsistencyMode', overriding its+-- default. Validates the model's schema and liveness, honours the wait mode,+-- then runs the query in a transaction. runQueryWith ::-    (IOE :> es, Store :> es) =>-    Maybe KeiroMetrics ->-    ConsistencyMode ->-    ReadModel q r ->-    q ->-    Eff es (Either ReadModelError r)+  (IOE :> es, Store :> es) =>+  Maybe KeiroMetrics ->+  ConsistencyMode ->+  ReadModel q r ->+  q ->+  Eff es (Either ReadModelError r) runQueryWith metrics consistency readModel input = do-    schemaCheck <- ensureReadModel readModel-    case schemaCheck of+  schemaCheck <- ensureReadModel readModel+  case schemaCheck of+    Left err -> pure (Left err)+    Right () -> do+      waitResult <- waitIfNeeded metrics consistency readModel+      case waitResult of         Left err -> pure (Left err)-        Right () -> do-            waitResult <- waitIfNeeded metrics consistency readModel-            case waitResult of-                Left err -> pure (Left err)-                Right () -> Right <$> runTransaction ((readModel ^. #query) input)+        Right () -> Right <$> runTransaction ((readModel ^. #query) input) -{- | Block until the model's subscription has advanced to @targetPosition@,-polling at 'pollMicros' intervals. Returns @Right ()@ once caught up, or-'ReadModelWaitTimeout' if 'timeoutMicros' elapses first.--}+-- | Block until the model's subscription has advanced to @targetPosition@,+-- polling at 'pollMicros' intervals. Returns @Right ()@ once caught up, or+-- 'ReadModelWaitTimeout' if 'timeoutMicros' elapses first. waitFor ::-    (IOE :> es, Store :> es) =>-    Maybe KeiroMetrics ->-    PositionWaitOptions ->-    ReadModel q r ->-    GlobalPosition ->-    Eff es (Either ReadModelError ())+  (IOE :> es, Store :> es) =>+  Maybe KeiroMetrics ->+  PositionWaitOptions ->+  ReadModel q r ->+  GlobalPosition ->+  Eff es (Either ReadModelError ()) waitFor metrics options readModel targetPosition = do-    started <- liftIO getCurrentTime-    poll started (GlobalPosition 0)+  started <- liftIO getCurrentTime+  poll started (GlobalPosition 0)   where     poll started observed = do-        current <- readSubscriptionPosition (readModel ^. #subscriptionName)-        let observed' = fromMaybe observed current-        if observed' >= targetPosition-            then pure (Right ())+      current <- readSubscriptionPosition (readModel ^. #subscriptionName)+      let observed' = fromMaybe observed current+      if observed' >= targetPosition+        then pure (Right ())+        else do+          now <- liftIO getCurrentTime+          let elapsedMicros =+                Prelude.floor+                  (diffUTCTime now started Prelude.* 1000000)+          if elapsedMicros >= options ^. #timeoutMicros+            then do+              -- A genuine give-up: bump keiro.projection.wait.timeouts (no-op+              -- under a 'Nothing' handle) before surfacing the timeout.+              recordProjectionWaitTimeouts metrics 1+              pure+                (Left (ReadModelWaitTimeout (readModel ^. #name) targetPosition observed'))             else do-                now <- liftIO getCurrentTime-                let elapsedMicros =-                        Prelude.floor-                            (diffUTCTime now started Prelude.* 1000000)-                if elapsedMicros >= options ^. #timeoutMicros-                    then do-                        -- A genuine give-up: bump keiro.projection.wait.timeouts (no-op-                        -- under a 'Nothing' handle) before surfacing the timeout.-                        recordProjectionWaitTimeouts metrics 1-                        pure-                            (Left (ReadModelWaitTimeout (readModel ^. #name) targetPosition observed'))-                    else do-                        liftIO (threadDelay (options ^. #pollMicros))-                        poll started observed'+              liftIO (threadDelay (options ^. #pollMicros))+              poll started observed'  -- Note: the read model's 'schema' field is deliberately NOT persisted here. The -- registry keys on name/version/shapeHash/status (the model's schema identity); -- where the application's data table physically lives is a deployment/wiring -- concern, not part of that identity. See EP-4's Decision Log. ensureReadModel ::-    (Store :> es) =>-    ReadModel q r ->-    Eff es (Either ReadModelError ())+  (Store :> es) =>+  ReadModel q r ->+  Eff es (Either ReadModelError ()) ensureReadModel readModel = do-    found <- lookupReadModel (readModel ^. #name)-    pure $ case found of-        Just metadata -> validateMetadata readModel metadata-        Nothing -> Left (ReadModelUnregistered (readModel ^. #name))+  found <- lookupReadModel (readModel ^. #name)+  pure $ case found of+    Just metadata -> validateMetadata readModel metadata+    Nothing -> Left (ReadModelUnregistered (readModel ^. #name))  validateMetadata :: ReadModel q r -> ReadModelMetadata -> Either ReadModelError () validateMetadata readModel metadata-    | metadata ^. #version /= readModel ^. #version =-        stale-    | metadata ^. #shapeHash /= readModel ^. #shapeHash =-        stale-    | metadata ^. #status /= Live =-        Left (ReadModelNotLive (readModel ^. #name) (metadata ^. #status))-    | otherwise =-        Right ()+  | metadata ^. #version /= readModel ^. #version =+      stale+  | metadata ^. #shapeHash /= readModel ^. #shapeHash =+      stale+  | metadata ^. #status /= Live =+      Left (ReadModelNotLive (readModel ^. #name) (metadata ^. #status))+  | otherwise =+      Right ()   where     stale =-        Left-            ( ReadModelStaleSchema-                (readModel ^. #name)-                (readModel ^. #version)-                (metadata ^. #version)-                (readModel ^. #shapeHash)-                (metadata ^. #shapeHash)-            )+      Left+        ( ReadModelStaleSchema+            (readModel ^. #name)+            (readModel ^. #version)+            (metadata ^. #version)+            (readModel ^. #shapeHash)+            (metadata ^. #shapeHash)+        )  waitIfNeeded ::-    (IOE :> es, Store :> es) =>-    Maybe KeiroMetrics ->-    ConsistencyMode ->-    ReadModel q r ->-    Eff es (Either ReadModelError ())+  (IOE :> es, Store :> es) =>+  Maybe KeiroMetrics ->+  ConsistencyMode ->+  ReadModel q r ->+  Eff es (Either ReadModelError ()) waitIfNeeded metrics Strong readModel = do-    target <- case readModel ^. #strongScope of-        EntireLog -> storeHeadPosition-        CategoryHead category -> categoryHeadPosition category-    waitFor metrics (defaultStrongWaitOptions & #target ?~ target) readModel target+  target <- case readModel ^. #strongScope of+    EntireLog -> storeHeadPosition+    CategoryHead category -> categoryHeadPosition category+  waitFor metrics (defaultStrongWaitOptions & #target ?~ target) readModel target waitIfNeeded _ Eventual _ = pure (Right ()) waitIfNeeded metrics (PositionWait options) readModel =-    case options ^. #target of-        Nothing -> pure (Right ())-        Just targetPosition -> waitFor metrics options readModel targetPosition+  case options ^. #target of+    Nothing -> pure (Right ())+    Just targetPosition -> waitFor metrics options readModel targetPosition  readSubscriptionPosition ::-    (Store :> es) =>-    Text ->-    Eff es (Maybe GlobalPosition)+  (Store :> es) =>+  Text ->+  Eff es (Maybe GlobalPosition) readSubscriptionPosition subscriptionName =-    runTransaction-        $ Tx.statement subscriptionName lookupSubscriptionPositionStmt+  runTransaction+    $ Tx.statement subscriptionName lookupSubscriptionPositionStmt  lookupSubscriptionPositionStmt :: Statement Text (Maybe GlobalPosition) lookupSubscriptionPositionStmt =-    preparable-        """-        SELECT min(last_seen)-        FROM subscriptions-        WHERE subscription_name = $1-        """-        (E.param (E.nonNullable E.text))-        (D.singleRow (fmap GlobalPosition <$> D.column (D.nullable D.int8)))+  preparable+    """+    SELECT min(last_seen)+    FROM subscriptions+    WHERE subscription_name = $1+    """+    (E.param (E.nonNullable E.text))+    (D.singleRow (fmap GlobalPosition <$> D.column (D.nullable D.int8))) -{- | The global position of the most recent event in the @$all@ log, or-@GlobalPosition 0@ when the log is empty. 'readAllBackward' treats-@GlobalPosition 0@ as "after everything", so a limit of 1 returns the head.--}+-- | The global position of the most recent event in the @$all@ log, or+-- @GlobalPosition 0@ when the log is empty. 'readAllBackward' treats+-- @GlobalPosition 0@ as "after everything", so a limit of 1 returns the head. storeHeadPosition :: (Store :> es) => Eff es GlobalPosition storeHeadPosition = do-    recent <- readAllBackward (GlobalPosition 0) 1-    pure $ case Vector.toList recent of-        (event : _) -> event ^. #globalPosition-        [] -> GlobalPosition 0+  recent <- readAllBackward (GlobalPosition 0) 1+  pure $ case Vector.toList recent of+    (event : _) -> event ^. #globalPosition+    [] -> GlobalPosition 0 -{- | The latest global position originating in a Kiroku category, or-@GlobalPosition 0@ when that category has no events. This deliberately reads-Kiroku's indexed @streams@ and @$all@ membership tables because Kiroku 0.3 does-not export a category-head query.--}+-- | The latest global position originating in a Kiroku category, or+-- @GlobalPosition 0@ when that category has no events. This deliberately reads+-- Kiroku's indexed @streams@ and @$all@ membership tables because Kiroku 0.3 does+-- not export a category-head query. categoryHeadPosition :: (Store :> es) => Text -> Eff es GlobalPosition categoryHeadPosition category =-    runTransaction-        $ Tx.statement category categoryHeadPositionStmt+  runTransaction+    $ Tx.statement category categoryHeadPositionStmt  categoryHeadPositionStmt :: Statement Text GlobalPosition categoryHeadPositionStmt =-    preparable-        """-        SELECT COALESCE(max(se.stream_version), 0)-        FROM streams s-        JOIN stream_events se-          ON se.original_stream_id = s.stream_id-         AND se.stream_id = 0-        WHERE s.category = $1-        """-        (E.param (E.nonNullable E.text))-        (D.singleRow (GlobalPosition <$> D.column (D.nonNullable D.int8)))+  preparable+    """+    SELECT COALESCE(max(se.stream_version), 0)+    FROM streams s+    JOIN stream_events se+      ON se.original_stream_id = s.stream_id+     AND se.stream_id = 0+    WHERE s.category = $1+    """+    (E.param (E.nonNullable E.text))+    (D.singleRow (GlobalPosition <$> D.column (D.nonNullable D.int8)))
src/Keiro/ReadModel/Rebuild.hs view
@@ -1,39 +1,38 @@-{- | The supported offline read-model rebuild lifecycle.--Use this checklist rather than composing the low-level status transitions:--1. Call 'Keiro.ReadModel.Schema.registerReadModel' once at projection startup.-   Explicit registration makes misspelled or never-populated models fail with-   'ReadModelUnregistered' instead of appearing healthy.-2. Call 'startRebuild' with every feeding async projection name and the replay-   position. It atomically fences live writers, takes queries offline, truncates-   the data table, clears the named dedup keys, and resets the subscription-   checkpoint, preventing live/replay interleaving and all-deduplicated rebuilds.-3. Replay through 'Keiro.Projection.applyAsyncProjectionUnfenced'. This is the-   only apply path allowed to bypass the live-writer fence, while retaining-   deduplication inside the designated rebuild.-4. After replay catches up and application-specific verification succeeds, call-   'finishRebuild' with the same projection names and replay position. Its-   promotion guard refuses to serve a non-empty-log rebuild that applied no-   events.-5. If replay or verification fails, call 'abandonRebuild'. Queries remain-   unavailable instead of exposing partial data; repair or restore the table-   before beginning another rebuild.--Normal workers continue to call 'Keiro.Projection.applyAsyncProjection'. Its-registry lock fences them automatically while the model is rebuilding, but they-must not checkpoint an 'Keiro.Projection.AsyncFenced' event. Keiro does not yet-provide a shadow-table or online cutover mechanism; applications that need-zero-downtime rebuilds must build that orchestration above this lifecycle API.--}-module Keiro.ReadModel.Rebuild (-    RebuildError (..),+-- | The supported offline read-model rebuild lifecycle.+--+-- Use this checklist rather than composing the low-level status transitions:+--+-- 1. Call 'Keiro.ReadModel.Schema.registerReadModel' once at projection startup.+--    Explicit registration makes misspelled or never-populated models fail with+--    'ReadModelUnregistered' instead of appearing healthy.+-- 2. Call 'startRebuild' with every feeding async projection name and the replay+--    position. It atomically fences live writers, takes queries offline, truncates+--    the data table, clears the named dedup keys, and resets the subscription+--    checkpoint, preventing live/replay interleaving and all-deduplicated rebuilds.+-- 3. Replay through 'Keiro.Projection.applyAsyncProjectionUnfenced'. This is the+--    only apply path allowed to bypass the live-writer fence, while retaining+--    deduplication inside the designated rebuild.+-- 4. After replay catches up and application-specific verification succeeds, call+--    'finishRebuild' with the same projection names and replay position. Its+--    promotion guard refuses to serve a non-empty-log rebuild that applied no+--    events.+-- 5. If replay or verification fails, call 'abandonRebuild'. Queries remain+--    unavailable instead of exposing partial data; repair or restore the table+--    before beginning another rebuild.+--+-- Normal workers continue to call 'Keiro.Projection.applyAsyncProjection'. Its+-- registry lock fences them automatically while the model is rebuilding, but they+-- must not checkpoint an 'Keiro.Projection.AsyncFenced' event. Keiro does not yet+-- provide a shadow-table or online cutover mechanism; applications that need+-- zero-downtime rebuilds must build that orchestration above this lifecycle API.+module Keiro.ReadModel.Rebuild+  ( RebuildError (..),     startRebuild,     finishRebuild,     rebuild,     promote,     abandonRebuild,-)+  ) where  import Contravariant.Extras (contrazip2)@@ -51,146 +50,141 @@  -- | Why a rebuild could not be promoted. data RebuildError-    = {- | The model name and current store head when a rebuild started before-      existing events but applied none of its feeding projections.-      -}-      RebuildProducedNoApplies !Text !GlobalPosition-    deriving stock (Generic, Eq, Show)--{- | Atomically take a model offline, truncate its data table, clear the dedup-keys for its feeding async projections, and reset every member of its-subscription to the supplied replay position.+  = -- | The model name and current store head when a rebuild started before+    --       existing events but applied none of its feeding projections.+    RebuildProducedNoApplies !Text !GlobalPosition+  deriving stock (Generic, Eq, Show) -The registry transition runs first and holds the row lock that-'Keiro.Projection.applyAsyncProjection' uses as its writer fence. PostgreSQL-keeps the table truncate transactional. Kiroku's public checkpoint save is-monotonic, so this helper deliberately resets @subscriptions.last_seen@-directly inside the same fenced transaction.--}+-- | Atomically take a model offline, truncate its data table, clear the dedup+-- keys for its feeding async projections, and reset every member of its+-- subscription to the supplied replay position.+--+-- The registry transition runs first and holds the row lock that+-- 'Keiro.Projection.applyAsyncProjection' uses as its writer fence. PostgreSQL+-- keeps the table truncate transactional. Kiroku's public checkpoint save is+-- monotonic, so this helper deliberately resets @subscriptions.last_seen@+-- directly inside the same fenced transaction. startRebuild ::-    (Store :> es) =>-    ReadModel q r ->-    [Text] ->-    GlobalPosition ->-    Eff es ReadModelMetadata+  (Store :> es) =>+  ReadModel q r ->+  [Text] ->+  GlobalPosition ->+  Eff es ReadModelMetadata startRebuild readModel projectionNames replayFrom =-    runTransaction $ do-        metadata <- transitionReadModelTxFor readModel Rebuilding-        Tx.sql (TE.encodeUtf8 ("TRUNCATE TABLE " <> qualifiedTableName readModel))-        unless (null projectionNames) $-            Tx.statement projectionNames deleteProjectionDedupStmt-        Tx.statement-            (readModel ^. #subscriptionName, globalPositionToInt replayFrom)-            resetSubscriptionCheckpointStmt-        pure metadata--{- | Promote a completed rebuild in the same transaction as its safety check.+  runTransaction $ do+    metadata <- transitionReadModelTxFor readModel Rebuilding+    Tx.sql (TE.encodeUtf8 ("TRUNCATE TABLE " <> qualifiedTableName readModel))+    unless (null projectionNames) $+      Tx.statement projectionNames deleteProjectionDedupStmt+    Tx.statement+      (readModel ^. #subscriptionName, globalPositionToInt replayFrom)+      resetSubscriptionCheckpointStmt+    pure metadata -When async projection names are supplied, a store head beyond @replayFrom@-requires at least one new dedup row. 'startRebuild' deleted those rows, so their-count is the model-independent number of projection applications during this-rebuild. An empty projection-name list denotes an inline-only model and skips-the guard because no async dedup rows can exist for it.--}+-- | Promote a completed rebuild in the same transaction as its safety check.+--+-- When async projection names are supplied, a store head beyond @replayFrom@+-- requires at least one new dedup row. 'startRebuild' deleted those rows, so their+-- count is the model-independent number of projection applications during this+-- rebuild. An empty projection-name list denotes an inline-only model and skips+-- the guard because no async dedup rows can exist for it. finishRebuild ::-    (Store :> es) =>-    ReadModel q r ->-    [Text] ->-    GlobalPosition ->-    Eff es (Either RebuildError ReadModelMetadata)+  (Store :> es) =>+  ReadModel q r ->+  [Text] ->+  GlobalPosition ->+  Eff es (Either RebuildError ReadModelMetadata) finishRebuild readModel projectionNames replayFrom =-    runTransaction $ do-        headPosition <- Tx.statement () storeHeadPositionStmt-        applyCount <--            if null projectionNames-                then pure 0-                else Tx.statement projectionNames countProjectionDedupStmt-        if null projectionNames || applyCount > 0 || headPosition <= replayFrom-            then Right <$> transitionReadModelTxFor readModel Live-            else pure (Left (RebuildProducedNoApplies (readModel ^. #name) headPosition))+  runTransaction $ do+    headPosition <- Tx.statement () storeHeadPositionStmt+    applyCount <-+      if null projectionNames+        then pure 0+        else Tx.statement projectionNames countProjectionDedupStmt+    if null projectionNames || applyCount > 0 || headPosition <= replayFrom+      then Right <$> transitionReadModelTxFor readModel Live+      else pure (Left (RebuildProducedNoApplies (readModel ^. #name) headPosition)) -{- | Low-level status transition only. It does not truncate data, reset dedup-keys or checkpoints, or establish the complete rebuild workflow. Use-'startRebuild' for supported rebuilds.--}+-- | Low-level status transition only. It does not truncate data, reset dedup+-- keys or checkpoints, or establish the complete rebuild workflow. Use+-- 'startRebuild' for supported rebuilds. rebuild :: (Store :> es) => ReadModel q r -> Eff es ReadModelMetadata rebuild readModel =-    markRebuilding-        (readModel ^. #name)-        (readModel ^. #version)-        (readModel ^. #shapeHash)+  markRebuilding+    (readModel ^. #name)+    (readModel ^. #version)+    (readModel ^. #shapeHash) -{- | Low-level status transition only. It bypasses the empty-rebuild guard. Use-'finishRebuild' to promote a supported rebuild.--}+-- | Low-level status transition only. It bypasses the empty-rebuild guard. Use+-- 'finishRebuild' to promote a supported rebuild. promote :: (Store :> es) => ReadModel q r -> Eff es ReadModelMetadata promote readModel =-    markLive-        (readModel ^. #name)-        (readModel ^. #version)-        (readModel ^. #shapeHash)+  markLive+    (readModel ^. #name)+    (readModel ^. #version)+    (readModel ^. #shapeHash)  -- | Mark a model 'Abandoned', backing out of an in-progress rebuild. abandonRebuild :: (Store :> es) => ReadModel q r -> Eff es ReadModelMetadata abandonRebuild readModel =-    markAbandoned-        (readModel ^. #name)-        (readModel ^. #version)-        (readModel ^. #shapeHash)+  markAbandoned+    (readModel ^. #name)+    (readModel ^. #version)+    (readModel ^. #shapeHash)  transitionReadModelTxFor :: ReadModel q r -> ReadModelStatus -> Tx.Transaction ReadModelMetadata transitionReadModelTxFor readModel status =-    transitionReadModelTx-        (readModel ^. #name)-        (readModel ^. #version)-        (readModel ^. #shapeHash)-        status+  transitionReadModelTx+    (readModel ^. #name)+    (readModel ^. #version)+    (readModel ^. #shapeHash)+    status  deleteProjectionDedupStmt :: Statement [Text] () deleteProjectionDedupStmt =-    preparable-        """-        DELETE FROM keiro.keiro_projection_dedup-        WHERE projection_name = ANY($1)-        """-        (E.param (E.nonNullable (E.foldableArray (E.nonNullable E.text))))-        D.noResult+  preparable+    """+    DELETE FROM keiro.keiro_projection_dedup+    WHERE projection_name = ANY($1)+    """+    (E.param (E.nonNullable (E.foldableArray (E.nonNullable E.text))))+    D.noResult  countProjectionDedupStmt :: Statement [Text] Int64 countProjectionDedupStmt =-    preparable-        """-        SELECT count(*)-        FROM keiro.keiro_projection_dedup-        WHERE projection_name = ANY($1)-        """-        (E.param (E.nonNullable (E.foldableArray (E.nonNullable E.text))))-        (D.singleRow (D.column (D.nonNullable D.int8)))+  preparable+    """+    SELECT count(*)+    FROM keiro.keiro_projection_dedup+    WHERE projection_name = ANY($1)+    """+    (E.param (E.nonNullable (E.foldableArray (E.nonNullable E.text))))+    (D.singleRow (D.column (D.nonNullable D.int8)))  resetSubscriptionCheckpointStmt :: Statement (Text, Int64) () resetSubscriptionCheckpointStmt =-    preparable-        """-        UPDATE subscriptions-        SET last_seen = $2, updated_at = now()-        WHERE subscription_name = $1-        """-        ( contrazip2-            (E.param (E.nonNullable E.text))-            (E.param (E.nonNullable E.int8))-        )-        D.noResult+  preparable+    """+    UPDATE subscriptions+    SET last_seen = $2, updated_at = now()+    WHERE subscription_name = $1+    """+    ( contrazip2+        (E.param (E.nonNullable E.text))+        (E.param (E.nonNullable E.int8))+    )+    D.noResult  storeHeadPositionStmt :: Statement () GlobalPosition storeHeadPositionStmt =-    preparable-        """-        SELECT COALESCE(max(stream_version), 0)-        FROM stream_events-        WHERE stream_id = 0-        """-        E.noParams-        (D.singleRow (GlobalPosition <$> D.column (D.nonNullable D.int8)))+  preparable+    """+    SELECT COALESCE(max(stream_version), 0)+    FROM stream_events+    WHERE stream_id = 0+    """+    E.noParams+    (D.singleRow (GlobalPosition <$> D.column (D.nonNullable D.int8)))  globalPositionToInt :: GlobalPosition -> Int64 globalPositionToInt (GlobalPosition position) = position
src/Keiro/ReadModel/Schema.hs view
@@ -1,19 +1,18 @@-{- | The @keiro_read_models@ registry: schema identity and lifecycle status.--Every read model explicitly registers a row at projection startup recording its 'version', 'shapeHash', and-'ReadModelStatus'. The registry is what lets 'Keiro.ReadModel.runQuery'-refuse to serve a model whose code-side schema has drifted from the table on-disk, or one that is mid-rebuild. The status transitions ('markRebuilding',-'markLive', 'markAbandoned') drive the rebuild workflow in-"Keiro.ReadModel.Rebuild".--All operations run as single-statement 'Hasql.Transaction.Transaction's-against the @keiro_read_models@ table; an unrecognized stored status decodes-to 'UnknownStatus' so callers see the raw database value instead of a silent-fallback.--}-module Keiro.ReadModel.Schema (-    -- * Metadata+-- | The @keiro_read_models@ registry: schema identity and lifecycle status.+--+-- Every read model explicitly registers a row at projection startup recording its 'version', 'shapeHash', and+-- 'ReadModelStatus'. The registry is what lets 'Keiro.ReadModel.runQuery'+-- refuse to serve a model whose code-side schema has drifted from the table on+-- disk, or one that is mid-rebuild. The status transitions ('markRebuilding',+-- 'markLive', 'markAbandoned') drive the rebuild workflow in+-- "Keiro.ReadModel.Rebuild".+--+-- All operations run as single-statement 'Hasql.Transaction.Transaction's+-- against the @keiro_read_models@ table; an unrecognized stored status decodes+-- to 'UnknownStatus' so callers see the raw database value instead of a silent+-- fallback.+module Keiro.ReadModel.Schema+  ( -- * Metadata     ReadModelMetadata (..),     ReadModelStatus (..), @@ -26,7 +25,7 @@     markLive,     markAbandoned,     transitionReadModelTx,-)+  ) where  import Contravariant.Extras (contrazip3, contrazip4)@@ -40,166 +39,159 @@ import "hasql-transaction" Hasql.Transaction qualified as Tx import Prelude qualified -{- | Lifecycle status of a registered read model.--* 'Live' — current and queryable.-* 'Rebuilding' — being repopulated from the event log; not yet queryable.-* 'Paused' — temporarily not served.-* 'Abandoned' — a rebuild that was given up on.-* 'UnknownStatus' — a database value this library version does not recognize.--}+-- | Lifecycle status of a registered read model.+--+-- * 'Live' — current and queryable.+-- * 'Rebuilding' — being repopulated from the event log; not yet queryable.+-- * 'Paused' — temporarily not served.+-- * 'Abandoned' — a rebuild that was given up on.+-- * 'UnknownStatus' — a database value this library version does not recognize. data ReadModelStatus-    = Live-    | Rebuilding-    | Paused-    | Abandoned-    | UnknownStatus !Text-    deriving stock (Generic, Eq, Show)+  = Live+  | Rebuilding+  | Paused+  | Abandoned+  | UnknownStatus !Text+  deriving stock (Generic, Eq, Show) -{- | One row of the @keiro_read_models@ registry: a model's name, schema-identity ('version' and 'shapeHash'), the time it was last (re)built, and-its current 'status'.--}+-- | One row of the @keiro_read_models@ registry: a model's name, schema+-- identity ('version' and 'shapeHash'), the time it was last (re)built, and+-- its current 'status'. data ReadModelMetadata = ReadModelMetadata-    { name :: !Text-    , version :: !Int-    , shapeHash :: !Text-    , lastBuiltAt :: !(Maybe UTCTime)-    , status :: !ReadModelStatus-    }-    deriving stock (Generic, Eq, Show)+  { name :: !Text,+    version :: !Int,+    shapeHash :: !Text,+    lastBuiltAt :: !(Maybe UTCTime),+    status :: !ReadModelStatus+  }+  deriving stock (Generic, Eq, Show) -{- | Register a read model once at projection startup, inserting a 'Live' row-if none exists. Querying never performs this registration automatically, so-deployments that previously relied on their first query to register must add-this startup call. Idempotent:-an existing registration is returned unchanged (the @version@ and-@shapeHash@ are /not/ overwritten), so a query can compare them and detect-schema drift.--}+-- | Register a read model once at projection startup, inserting a 'Live' row+-- if none exists. Querying never performs this registration automatically, so+-- deployments that previously relied on their first query to register must add+-- this startup call. Idempotent:+-- an existing registration is returned unchanged (the @version@ and+-- @shapeHash@ are /not/ overwritten), so a query can compare them and detect+-- schema drift. registerReadModel :: (Store :> es) => Text -> Int -> Text -> Eff es ReadModelMetadata registerReadModel name version shapeHash =-    runTransaction-        $ Tx.statement-            (name, Prelude.fromIntegral version, shapeHash)-            registerReadModelStmt+  runTransaction+    $ Tx.statement+      (name, Prelude.fromIntegral version, shapeHash)+      registerReadModelStmt  -- | Look up a read model's registry row by name, if it exists. lookupReadModel :: (Store :> es) => Text -> Eff es (Maybe ReadModelMetadata) lookupReadModel name =-    runTransaction-        $ Tx.statement name lookupReadModelStmt+  runTransaction+    $ Tx.statement name lookupReadModelStmt -{- | Upsert the registry row to 'Rebuilding' at the given schema identity.-Marks the model as being repopulated so queries stop serving it until-'markLive'.--}+-- | Upsert the registry row to 'Rebuilding' at the given schema identity.+-- Marks the model as being repopulated so queries stop serving it until+-- 'markLive'. markRebuilding :: (Store :> es) => Text -> Int -> Text -> Eff es ReadModelMetadata markRebuilding name version shapeHash =-    runTransaction $ transitionReadModelTx name version shapeHash Rebuilding+  runTransaction $ transitionReadModelTx name version shapeHash Rebuilding -{- | Upsert the registry row to 'Live' at the given schema identity, stamping-@last_built_at@. Makes the model queryable again after a rebuild.--}+-- | Upsert the registry row to 'Live' at the given schema identity, stamping+-- @last_built_at@. Makes the model queryable again after a rebuild. markLive :: (Store :> es) => Text -> Int -> Text -> Eff es ReadModelMetadata markLive name version shapeHash =-    runTransaction $ transitionReadModelTx name version shapeHash Live+  runTransaction $ transitionReadModelTx name version shapeHash Live -{- | Upsert the registry row to 'Abandoned' at the given schema identity,-recording that a rebuild was given up on.--}+-- | Upsert the registry row to 'Abandoned' at the given schema identity,+-- recording that a rebuild was given up on. markAbandoned :: (Store :> es) => Text -> Int -> Text -> Eff es ReadModelMetadata markAbandoned name version shapeHash =-    runTransaction $ transitionReadModelTx name version shapeHash Abandoned+  runTransaction $ transitionReadModelTx name version shapeHash Abandoned -{- | Transaction-composable form of a registry status transition. Rebuild-orchestration uses this form so the status row lock, table reset, dedup reset,-and checkpoint reset share one database transaction.--}+-- | Transaction-composable form of a registry status transition. Rebuild+-- orchestration uses this form so the status row lock, table reset, dedup reset,+-- and checkpoint reset share one database transaction. transitionReadModelTx :: Text -> Int -> Text -> ReadModelStatus -> Tx.Transaction ReadModelMetadata transitionReadModelTx name version shapeHash status =-    Tx.statement-        (name, Prelude.fromIntegral version, shapeHash, statusToText status)-        transitionReadModelStmt+  Tx.statement+    (name, Prelude.fromIntegral version, shapeHash, statusToText status)+    transitionReadModelStmt  registerReadModelStmt :: Statement (Text, Int64, Text) ReadModelMetadata registerReadModelStmt =-    preparable-        """-        INSERT INTO keiro.keiro_read_models (name, version, shape_hash, status, last_built_at)-        VALUES ($1, $2, $3, 'live', now())-        ON CONFLICT (name) DO UPDATE-          SET name = EXCLUDED.name-        RETURNING name, version, shape_hash, last_built_at, status-        """-        ( contrazip3-            (E.param (E.nonNullable E.text))-            (E.param (E.nonNullable E.int8))-            (E.param (E.nonNullable E.text))-        )-        readModelMetadataSingle+  preparable+    """+    INSERT INTO keiro.keiro_read_models (name, version, shape_hash, status, last_built_at)+    VALUES ($1, $2, $3, 'live', now())+    ON CONFLICT (name) DO UPDATE+      SET name = EXCLUDED.name+    RETURNING name, version, shape_hash, last_built_at, status+    """+    ( contrazip3+        (E.param (E.nonNullable E.text))+        (E.param (E.nonNullable E.int8))+        (E.param (E.nonNullable E.text))+    )+    readModelMetadataSingle  lookupReadModelStmt :: Statement Text (Maybe ReadModelMetadata) lookupReadModelStmt =-    preparable-        """-        SELECT name, version, shape_hash, last_built_at, status-        FROM keiro.keiro_read_models-        WHERE name = $1-        """-        (E.param (E.nonNullable E.text))-        (D.rowMaybe readModelMetadataDecoder)+  preparable+    """+    SELECT name, version, shape_hash, last_built_at, status+    FROM keiro.keiro_read_models+    WHERE name = $1+    """+    (E.param (E.nonNullable E.text))+    (D.rowMaybe readModelMetadataDecoder)  transitionReadModelStmt :: Statement (Text, Int64, Text, Text) ReadModelMetadata transitionReadModelStmt =-    preparable-        """-        INSERT INTO keiro.keiro_read_models (name, version, shape_hash, status, last_built_at, updated_at)-        VALUES ($1, $2, $3, $4, now(), now())-        ON CONFLICT (name) DO UPDATE-          SET version = EXCLUDED.version,-              shape_hash = EXCLUDED.shape_hash,-              status = EXCLUDED.status,-              last_built_at = CASE-                WHEN EXCLUDED.status = 'live' THEN now()-                ELSE keiro_read_models.last_built_at-              END,-              updated_at = now()-        RETURNING name, version, shape_hash, last_built_at, status-        """-        ( contrazip4-            (E.param (E.nonNullable E.text))-            (E.param (E.nonNullable E.int8))-            (E.param (E.nonNullable E.text))-            (E.param (E.nonNullable E.text))-        )-        readModelMetadataSingle+  preparable+    """+    INSERT INTO keiro.keiro_read_models (name, version, shape_hash, status, last_built_at, updated_at)+    VALUES ($1, $2, $3, $4, now(), now())+    ON CONFLICT (name) DO UPDATE+      SET version = EXCLUDED.version,+          shape_hash = EXCLUDED.shape_hash,+          status = EXCLUDED.status,+          last_built_at = CASE+            WHEN EXCLUDED.status = 'live' THEN now()+            ELSE keiro_read_models.last_built_at+          END,+          updated_at = now()+    RETURNING name, version, shape_hash, last_built_at, status+    """+    ( contrazip4+        (E.param (E.nonNullable E.text))+        (E.param (E.nonNullable E.int8))+        (E.param (E.nonNullable E.text))+        (E.param (E.nonNullable E.text))+    )+    readModelMetadataSingle  readModelMetadataSingle :: D.Result ReadModelMetadata readModelMetadataSingle =-    D.singleRow readModelMetadataDecoder+  D.singleRow readModelMetadataDecoder  readModelMetadataDecoder :: D.Row ReadModelMetadata readModelMetadataDecoder =-    ReadModelMetadata-        <$> D.column (D.nonNullable D.text)-        <*> (Prelude.fromIntegral <$> D.column (D.nonNullable D.int8))-        <*> D.column (D.nonNullable D.text)-        <*> D.column (D.nullable D.timestamptz)-        <*> (statusFromText <$> D.column (D.nonNullable D.text))+  ReadModelMetadata+    <$> D.column (D.nonNullable D.text)+    <*> (Prelude.fromIntegral <$> D.column (D.nonNullable D.int8))+    <*> D.column (D.nonNullable D.text)+    <*> D.column (D.nullable D.timestamptz)+    <*> (statusFromText <$> D.column (D.nonNullable D.text))  statusToText :: ReadModelStatus -> Text statusToText = \case-    Live -> "live"-    Rebuilding -> "rebuilding"-    Paused -> "paused"-    Abandoned -> "abandoned"-    UnknownStatus raw -> raw+  Live -> "live"+  Rebuilding -> "rebuilding"+  Paused -> "paused"+  Abandoned -> "abandoned"+  UnknownStatus raw -> raw  statusFromText :: Text -> ReadModelStatus statusFromText = \case-    "live" -> Live-    "rebuilding" -> Rebuilding-    "paused" -> Paused-    "abandoned" -> Abandoned-    raw -> UnknownStatus raw+  "live" -> Live+  "rebuilding" -> Rebuilding+  "paused" -> Paused+  "abandoned" -> Abandoned+  raw -> UnknownStatus raw
src/Keiro/ReplayAudit.hs view
@@ -1,22 +1,21 @@ {-# LANGUAGE GADTs #-} -{- | Read-only, differential replay audits for aggregate event streams.--Routine deploys should first consume @keiro-dsl diff@'s replay-impact verdict:-a replay-neutral deploy touches no data, while an affected verdict supplies the-event types for 'AuditTargeted'. 'AuditFull' is intentionally reserved for-one-time runtime cutovers and forensics.--Selection is read-only and server-side. It uses Kiroku's indexed category,-event-type, and global-position schema to discover only candidate stream names;-each candidate is then hydrated through the public Store effect. The audit-never appends events, calls @verifyAndSnapshot@, or writes snapshots.--Hand-written services have no spec from which to derive an affected set. They-must supply a conservative set explicitly or choose 'AuditFull'.--}-module Keiro.ReplayAudit (-    AuditMode (..),+-- | Read-only, differential replay audits for aggregate event streams.+--+-- Routine deploys should first consume @keiro-dsl diff@'s replay-impact verdict:+-- a replay-neutral deploy touches no data, while an affected verdict supplies the+-- event types for 'AuditTargeted'. 'AuditFull' is intentionally reserved for+-- one-time runtime cutovers and forensics.+--+-- Selection is read-only and server-side. It uses Kiroku's indexed category,+-- event-type, and global-position schema to discover only candidate stream names;+-- each candidate is then hydrated through the public Store effect. The audit+-- never appends events, calls @verifyAndSnapshot@, or writes snapshots.+--+-- Hand-written services have no spec from which to derive an affected set. They+-- must supply a conservative set explicitly or choose 'AuditFull'.+module Keiro.ReplayAudit+  ( AuditMode (..),     AffectedSet (..),     AuditBudget (..),     defaultAuditBudget,@@ -31,7 +30,8 @@     auditTargets,     renderAuditReport,     auditExitCode,-) where+  )+where  import Contravariant.Extras (contrazip3, contrazip5) import Data.Int (Int32)@@ -48,14 +48,14 @@ import Hasql.Encoders qualified as E import Hasql.Statement (Statement, preparable) import Keiki.Core (BoolAlg, RegFile)-import Keiro.Command (-    CommandError,+import Keiro.Command+  ( CommandError,     Hydrated (..),     RunCommandOptions,     defaultRunCommandOptions,     hydrateFull,     hydrateSeeded,- )+  ) import Keiro.EventStream (EventStream, StateCodec) import Keiro.EventStream.Validate (ValidatedEventStream, unvalidated) import Keiro.Prelude@@ -65,486 +65,485 @@ import Kiroku.Store.Effect (Store) import Kiroku.Store.Read (lookupStreamNames) import Kiroku.Store.Transaction (runTransaction)-import Kiroku.Store.Types (-    CategoryName (..),+import Kiroku.Store.Types+  ( CategoryName (..),     EventType (..),     GlobalPosition (..),     StreamId (..),     StreamName (..),     StreamVersion,- )+  ) import Kiroku.Store.Types qualified as StoreTypes import "hasql-transaction" Hasql.Transaction qualified as Tx import Prelude qualified  -- | Which streams to inspect. data AuditMode-    = AuditFull-    | AuditTargeted !AffectedSet-    deriving stock (Eq, Show, Generic)+  = AuditFull+  | AuditTargeted !AffectedSet+  deriving stock (Eq, Show, Generic)  -- | Conservative stored-data surface emitted by the DSL replay-impact diff. data AffectedSet = AffectedSet-    { affectedEventTypes :: !(Set EventType)-    , includeSnapshotStreams :: !Bool-    }-    deriving stock (Eq, Show, Generic)--{- | Per-run cost and resume controls.+  { affectedEventTypes :: !(Set EventType),+    includeSnapshotStreams :: !Bool+  }+  deriving stock (Eq, Show, Generic) -The checkpoint is the maximum global position of the last audited stream at-the selection snapshot. Re-running with that checkpoint selects only streams-whose latest event lies after it. A category that receives new events during-or after a run may intentionally cause a previously checked stream to be-selected again: its durable history changed and warrants another verdict.--}+-- | Per-run cost and resume controls.+--+-- The checkpoint is the maximum global position of the last audited stream at+-- the selection snapshot. Re-running with that checkpoint selects only streams+-- whose latest event lies after it. A category that receives new events during+-- or after a run may intentionally cause a previously checked stream to be+-- selected again: its durable history changed and warrants another verdict. data AuditBudget = AuditBudget-    { maxStreams :: !(Maybe Int)-    , parallelism :: !Int-    , resumeFrom :: !(Maybe GlobalPosition)-    }-    deriving stock (Eq, Show, Generic)+  { maxStreams :: !(Maybe Int),+    parallelism :: !Int,+    resumeFrom :: !(Maybe GlobalPosition)+  }+  deriving stock (Eq, Show, Generic)  defaultAuditBudget :: AuditBudget defaultAuditBudget =-    AuditBudget-        { maxStreams = Nothing-        , parallelism = 4-        , resumeFrom = Nothing-        }+  AuditBudget+    { maxStreams = Nothing,+      parallelism = 4,+      resumeFrom = Nothing+    }  -- | One typed aggregate/category assembly. data AuditTarget phi rs s ci co = AuditTarget-    { eventStream :: !(ValidatedEventStream phi rs s ci co)-    , category :: !Text-    , mkStream :: !(StreamName -> Maybe (Stream (EventStream phi rs s ci co)))-    }-    deriving stock (Generic)+  { eventStream :: !(ValidatedEventStream phi rs s ci co),+    category :: !Text,+    mkStream :: !(StreamName -> Maybe (Stream (EventStream phi rs s ci co)))+  }+  deriving stock (Generic)  -- | Existential packaging for services with multiple aggregate types. data SomeAuditTarget where-    SomeAuditTarget ::-        (BoolAlg phi (RegFile rs, ci), Eq co) =>-        AuditTarget phi rs s ci co ->-        SomeAuditTarget+  SomeAuditTarget ::+    (BoolAlg phi (RegFile rs, ci), Eq co) =>+    AuditTarget phi rs s ci co ->+    SomeAuditTarget  -- | Accept a raw store name only when it belongs to the expected category. streamInCategory :: Text -> StreamName -> Maybe (Stream eventStream) streamInCategory expected streamName =-    case StoreTypes.categoryName streamName of-        CategoryName actual-            | actual == expected -> Just (Stream streamName)-        _ -> Nothing+  case StoreTypes.categoryName streamName of+    CategoryName actual+      | actual == expected -> Just (Stream streamName)+    _ -> Nothing  -- | Replay result for one accepted stream name. data AuditOutcome-    = ReplayOk-        { streamVersion :: !StreamVersion-        , digest :: !(Maybe Text)-        }-    | ReplayFailed-        { commandError :: !CommandError-        }-    | SeedDivergence-        { seedVersion :: !StreamVersion-        , seededDigest :: !Text-        , fullDigest :: !Text-        }-    deriving stock (Eq, Show, Generic)+  = ReplayOk+      { streamVersion :: !StreamVersion,+        digest :: !(Maybe Text)+      }+  | ReplayFailed+      { commandError :: !CommandError+      }+  | SeedDivergence+      { seedVersion :: !StreamVersion,+        seededDigest :: !Text,+        fullDigest :: !Text+      }+  deriving stock (Eq, Show, Generic)  data StreamAuditResult = StreamAuditResult-    { streamName :: !StreamName-    , outcome :: !AuditOutcome-    }-    deriving stock (Eq, Show, Generic)+  { streamName :: !StreamName,+    outcome :: !AuditOutcome+  }+  deriving stock (Eq, Show, Generic)  data AuditReport = AuditReport-    { targetCategory :: !Text-    , mode :: !Text-    , results :: ![StreamAuditResult]-    , rejectedStreams :: ![StreamName]-    , streamsSelected :: !Int-    , streamsSkipped :: !Int-    , failures :: !Int-    , divergences :: !Int-    , checkpoint :: !(Maybe GlobalPosition)-    }-    deriving stock (Eq, Show, Generic)+  { targetCategory :: !Text,+    mode :: !Text,+    results :: ![StreamAuditResult],+    rejectedStreams :: ![StreamName],+    streamsSelected :: !Int,+    streamsSkipped :: !Int,+    failures :: !Int,+    divergences :: !Int,+    checkpoint :: !(Maybe GlobalPosition)+  }+  deriving stock (Eq, Show, Generic)  auditStream ::-    forall phi rs s ci co es.-    (Store :> es, BoolAlg phi (RegFile rs, ci), Eq co) =>-    AuditTarget phi rs s ci co ->-    Stream (EventStream phi rs s ci co) ->-    Eff es AuditOutcome+  forall phi rs s ci co es.+  (Store :> es, BoolAlg phi (RegFile rs, ci), Eq co) =>+  AuditTarget phi rs s ci co ->+  Stream (EventStream phi rs s ci co) ->+  Eff es AuditOutcome auditStream target stream = do-    let raw = unvalidated (target ^. #eventStream)-        options = defaultRunCommandOptions-    hydrateFull options raw stream >>= \case-        Left err -> pure (ReplayFailed err)-        Right full ->-            case raw ^. #stateCodec of-                Nothing ->-                    pure-                        ReplayOk-                            { streamVersion = full ^. #streamVersion-                            , digest = Nothing-                            }-                Just codec -> auditSeed options raw codec full+  let raw = unvalidated (target ^. #eventStream)+      options = defaultRunCommandOptions+  hydrateFull options raw stream >>= \case+    Left err -> pure (ReplayFailed err)+    Right full ->+      case raw ^. #stateCodec of+        Nothing ->+          pure+            ReplayOk+              { streamVersion = full ^. #streamVersion,+                digest = Nothing+              }+        Just codec -> auditSeed options raw codec full   where     auditSeed ::-        RunCommandOptions ->-        EventStream phi rs s ci co ->-        StateCodec (s, RegFile rs) ->-        Hydrated rs s ->-        Eff es AuditOutcome+      RunCommandOptions ->+      EventStream phi rs s ci co ->+      StateCodec (s, RegFile rs) ->+      Hydrated rs s ->+      Eff es AuditOutcome     auditSeed options raw codec full = do-        let name = (raw ^. #resolveStreamName) stream-            fullValue = (codec ^. #encode) (full ^. #state, full ^. #registers)-            fullBytes = canonicalJsonBytes fullValue-            fullHash = replayDigest fullValue-        lookupSnapshotSeed name codec >>= \case-            SnapshotUnavailable _ ->+      let name = (raw ^. #resolveStreamName) stream+          fullValue = (codec ^. #encode) (full ^. #state, full ^. #registers)+          fullBytes = canonicalJsonBytes fullValue+          fullHash = replayDigest fullValue+      lookupSnapshotSeed name codec >>= \case+        SnapshotUnavailable _ ->+          pure+            ReplayOk+              { streamVersion = full ^. #streamVersion,+                digest = Just fullHash+              }+        SnapshotHit seed ->+          hydrateSeeded+            options+            raw+            stream+            (seed ^. #state)+            (seed ^. #registers)+            (seed ^. #streamVersion)+            >>= \case+              Left err ->                 pure-                    ReplayOk-                        { streamVersion = full ^. #streamVersion-                        , digest = Just fullHash-                        }-            SnapshotHit seed ->-                hydrateSeeded-                    options-                    raw-                    stream-                    (seed ^. #state)-                    (seed ^. #registers)-                    (seed ^. #streamVersion)-                    >>= \case-                        Left err ->-                            pure-                                SeedDivergence-                                    { seedVersion = seed ^. #streamVersion-                                    , seededDigest = "replay-failed:" <> Text.pack (show err)-                                    , fullDigest = fullHash-                                    }-                        Right seeded ->-                            let seededValue =-                                    (codec ^. #encode)-                                        (seeded ^. #state, seeded ^. #registers)-                                seededHash = replayDigest seededValue-                             in if canonicalJsonBytes seededValue == fullBytes-                                    then-                                        pure-                                            ReplayOk-                                                { streamVersion = full ^. #streamVersion-                                                , digest = Just fullHash-                                                }-                                    else-                                        pure-                                            SeedDivergence-                                                { seedVersion = seed ^. #streamVersion-                                                , seededDigest = seededHash-                                                , fullDigest = fullHash-                                                }+                  SeedDivergence+                    { seedVersion = seed ^. #streamVersion,+                      seededDigest = "replay-failed:" <> Text.pack (show err),+                      fullDigest = fullHash+                    }+              Right seeded ->+                let seededValue =+                      (codec ^. #encode)+                        (seeded ^. #state, seeded ^. #registers)+                    seededHash = replayDigest seededValue+                 in if canonicalJsonBytes seededValue == fullBytes+                      then+                        pure+                          ReplayOk+                            { streamVersion = full ^. #streamVersion,+                              digest = Just fullHash+                            }+                      else+                        pure+                          SeedDivergence+                            { seedVersion = seed ^. #streamVersion,+                              seededDigest = seededHash,+                              fullDigest = fullHash+                            }  auditStreams ::-    forall phi rs s ci co es.-    (IOE :> es, Store :> es, BoolAlg phi (RegFile rs, ci), Eq co) =>-    AuditMode ->-    AuditBudget ->-    AuditTarget phi rs s ci co ->-    Eff es AuditReport+  forall phi rs s ci co es.+  (IOE :> es, Store :> es, BoolAlg phi (RegFile rs, ci), Eq co) =>+  AuditMode ->+  AuditBudget ->+  AuditTarget phi rs s ci co ->+  Eff es AuditReport auditStreams auditMode budget target = do-    totalStreams <- categoryStreamCount (target ^. #category)-    selectedTotal <- selectedStreamCount auditMode (target ^. #category)-    let skipped =-            case auditMode of-                AuditFull -> 0-                AuditTargeted _ -> Prelude.max 0 (totalStreams Prelude.- selectedTotal)-        workerCount = Prelude.max 1 (budget ^. #parallelism)-        remaining0 = fmap (Prelude.max 0) (budget ^. #maxStreams)-        cursor0 = fromMaybe (GlobalPosition 0) (budget ^. #resumeFrom)-    (allResults, rejected, selected, finalCursor) <--        go workerCount remaining0 cursor0 [] [] 0-    let failureCount =-            Prelude.length rejected-                Prelude.+ Prelude.length-                    [ ()-                    | StreamAuditResult{outcome = ReplayFailed{}} <- allResults-                    ]-        divergenceCount =-            Prelude.length-                [ ()-                | StreamAuditResult{outcome = SeedDivergence{}} <- allResults-                ]-    pure-        AuditReport-            { targetCategory = target ^. #category-            , mode = case auditMode of AuditFull -> "full"; AuditTargeted _ -> "targeted"-            , results = allResults-            , rejectedStreams = rejected-            , streamsSelected = selected-            , streamsSkipped = skipped-            , failures = failureCount-            , divergences = divergenceCount-            , checkpoint =-                if selected == 0-                    then budget ^. #resumeFrom-                    else Just finalCursor-            }+  totalStreams <- categoryStreamCount (target ^. #category)+  selectedTotal <- selectedStreamCount auditMode (target ^. #category)+  let skipped =+        case auditMode of+          AuditFull -> 0+          AuditTargeted _ -> Prelude.max 0 (totalStreams Prelude.- selectedTotal)+      workerCount = Prelude.max 1 (budget ^. #parallelism)+      remaining0 = fmap (Prelude.max 0) (budget ^. #maxStreams)+      cursor0 = fromMaybe (GlobalPosition 0) (budget ^. #resumeFrom)+  (allResults, rejected, selected, finalCursor) <-+    go workerCount remaining0 cursor0 [] [] 0+  let failureCount =+        Prelude.length rejected+          Prelude.+ Prelude.length+            [ ()+            | StreamAuditResult {outcome = ReplayFailed {}} <- allResults+            ]+      divergenceCount =+        Prelude.length+          [ ()+          | StreamAuditResult {outcome = SeedDivergence {}} <- allResults+          ]+  pure+    AuditReport+      { targetCategory = target ^. #category,+        mode = case auditMode of AuditFull -> "full"; AuditTargeted _ -> "targeted",+        results = allResults,+        rejectedStreams = rejected,+        streamsSelected = selected,+        streamsSkipped = skipped,+        failures = failureCount,+        divergences = divergenceCount,+        checkpoint =+          if selected == 0+            then budget ^. #resumeFrom+            else Just finalCursor+      }   where     pageSize = 128      go ::-        Int ->-        Maybe Int ->-        GlobalPosition ->-        [StreamAuditResult] ->-        [StreamName] ->-        Int ->-        Eff es ([StreamAuditResult], [StreamName], Int, GlobalPosition)+      Int ->+      Maybe Int ->+      GlobalPosition ->+      [StreamAuditResult] ->+      [StreamName] ->+      Int ->+      Eff es ([StreamAuditResult], [StreamName], Int, GlobalPosition)     go workerCount remaining cursor resultAcc rejectedAcc selectedAcc-        | Just 0 <- remaining =-            pure-                ( Prelude.reverse resultAcc-                , Prelude.reverse rejectedAcc-                , selectedAcc-                , cursor+      | Just 0 <- remaining =+          pure+            ( Prelude.reverse resultAcc,+              Prelude.reverse rejectedAcc,+              selectedAcc,+              cursor+            )+      | otherwise = do+          let requestSize =+                maybe pageSize (Prelude.min pageSize) remaining+          page <- selectStreamPage auditMode (target ^. #category) cursor requestSize+          if Vector.null page+            then+              pure+                ( Prelude.reverse resultAcc,+                  Prelude.reverse rejectedAcc,+                  selectedAcc,+                  cursor                 )-        | otherwise = do-            let requestSize =-                    maybe pageSize (Prelude.min pageSize) remaining-            page <- selectStreamPage auditMode (target ^. #category) cursor requestSize-            if Vector.null page-                then-                    pure-                        ( Prelude.reverse resultAcc-                        , Prelude.reverse rejectedAcc-                        , selectedAcc-                        , cursor-                        )-                else do-                    names <- lookupStreamNames (Prelude.fst <$> Vector.toList page)-                    let resolved =-                            [ (streamName, streamValue)-                            | (streamId, _watermark) <- Vector.toList page-                            , Just streamName <- [Map.lookup streamId names]-                            , Just streamValue <- [(target ^. #mkStream) streamName]-                            ]-                        acceptedNames = Set.fromList (Prelude.fst <$> resolved)-                        pageNames =-                            [ streamName-                            | (streamId, _watermark) <- Vector.toList page-                            , Just streamName <- [Map.lookup streamId names]-                            ]-                        rejected =-                            Prelude.filter (`Set.notMember` acceptedNames) pageNames-                    audited <--                        runConcurrent-                            $ Async.pooledMapConcurrentlyN-                                workerCount-                                ( \(name, streamValue) ->-                                    StreamAuditResult name <$> auditStream target streamValue-                                )-                                resolved-                    let nextCursor = Prelude.snd (Vector.last page)-                        pageCount = Vector.length page-                        nextRemaining = (Prelude.- pageCount) <$> remaining-                    go-                        workerCount-                        nextRemaining-                        nextCursor-                        (Prelude.reverse audited <> resultAcc)-                        (Prelude.reverse rejected <> rejectedAcc)-                        (selectedAcc Prelude.+ pageCount)+            else do+              names <- lookupStreamNames (Prelude.fst <$> Vector.toList page)+              let resolved =+                    [ (streamName, streamValue)+                    | (streamId, _watermark) <- Vector.toList page,+                      Just streamName <- [Map.lookup streamId names],+                      Just streamValue <- [(target ^. #mkStream) streamName]+                    ]+                  acceptedNames = Set.fromList (Prelude.fst <$> resolved)+                  pageNames =+                    [ streamName+                    | (streamId, _watermark) <- Vector.toList page,+                      Just streamName <- [Map.lookup streamId names]+                    ]+                  rejected =+                    Prelude.filter (`Set.notMember` acceptedNames) pageNames+              audited <-+                runConcurrent+                  $ Async.pooledMapConcurrentlyN+                    workerCount+                    ( \(name, streamValue) ->+                        StreamAuditResult name <$> auditStream target streamValue+                    )+                    resolved+              let nextCursor = Prelude.snd (Vector.last page)+                  pageCount = Vector.length page+                  nextRemaining = (Prelude.- pageCount) <$> remaining+              go+                workerCount+                nextRemaining+                nextCursor+                (Prelude.reverse audited <> resultAcc)+                (Prelude.reverse rejected <> rejectedAcc)+                (selectedAcc Prelude.+ pageCount)  auditTargets ::-    (IOE :> es, Store :> es) =>-    AuditMode ->-    AuditBudget ->-    [SomeAuditTarget] ->-    Eff es [AuditReport]+  (IOE :> es, Store :> es) =>+  AuditMode ->+  AuditBudget ->+  [SomeAuditTarget] ->+  Eff es [AuditReport] auditTargets auditMode budget =-    traverse $ \(SomeAuditTarget target) -> auditStreams auditMode budget target+  traverse $ \(SomeAuditTarget target) -> auditStreams auditMode budget target  renderAuditReport :: AuditReport -> Text renderAuditReport report =-    Text.intercalate-        " "-        [ "replay-audit"-        , "category=" <> report ^. #targetCategory-        , "mode=" <> report ^. #mode-        , "selected=" <> textShow (report ^. #streamsSelected)-        , "skipped=" <> textShow (report ^. #streamsSkipped)-        , "failures=" <> textShow (report ^. #failures)-        , "divergences=" <> textShow (report ^. #divergences)-        , "checkpoint=" <> maybe "none" textShow (report ^. #checkpoint)-        ]+  Text.intercalate+    " "+    [ "replay-audit",+      "category=" <> report ^. #targetCategory,+      "mode=" <> report ^. #mode,+      "selected=" <> textShow (report ^. #streamsSelected),+      "skipped=" <> textShow (report ^. #streamsSkipped),+      "failures=" <> textShow (report ^. #failures),+      "divergences=" <> textShow (report ^. #divergences),+      "checkpoint=" <> maybe "none" textShow (report ^. #checkpoint)+    ]   where     textShow :: (Show a) => a -> Text     textShow = Text.pack . show  auditExitCode :: [AuditReport] -> Int auditExitCode reports-    | Prelude.any-        (\report -> report ^. #failures > 0 Prelude.|| report ^. #divergences > 0)-        reports =-        1-    | otherwise = 0+  | Prelude.any+      (\report -> report ^. #failures > 0 Prelude.|| report ^. #divergences > 0)+      reports =+      1+  | otherwise = 0  -- Selection -----------------------------------------------------------------  categoryStreamCount :: (Store :> es) => Text -> Eff es Int categoryStreamCount category =-    Prelude.fromIntegral <$> runTransaction (Tx.statement category categoryStreamCountStmt)+  Prelude.fromIntegral <$> runTransaction (Tx.statement category categoryStreamCountStmt)  selectedStreamCount :: (Store :> es) => AuditMode -> Text -> Eff es Int selectedStreamCount auditMode category =-    case auditMode of-        AuditFull -> categoryStreamCount category-        AuditTargeted affected ->-            Prelude.fromIntegral-                <$> runTransaction-                    ( Tx.statement-                        (category, eventTypeTexts affected, affected ^. #includeSnapshotStreams)-                        targetedStreamCountStmt-                    )+  case auditMode of+    AuditFull -> categoryStreamCount category+    AuditTargeted affected ->+      Prelude.fromIntegral+        <$> runTransaction+          ( Tx.statement+              (category, eventTypeTexts affected, affected ^. #includeSnapshotStreams)+              targetedStreamCountStmt+          )  selectStreamPage ::-    (Store :> es) =>-    AuditMode ->-    Text ->-    GlobalPosition ->-    Int ->-    Eff es (Vector (StreamId, GlobalPosition))+  (Store :> es) =>+  AuditMode ->+  Text ->+  GlobalPosition ->+  Int ->+  Eff es (Vector (StreamId, GlobalPosition)) selectStreamPage auditMode category (GlobalPosition cursor) limit =-    case auditMode of-        AuditFull ->-            runTransaction-                $ Tx.statement-                    (category, cursor, Prelude.fromIntegral limit)-                    fullStreamPageStmt-        AuditTargeted affected ->-            runTransaction-                $ Tx.statement-                    ( category-                    , eventTypeTexts affected-                    , affected ^. #includeSnapshotStreams-                    , cursor-                    , Prelude.fromIntegral limit-                    )-                    targetedStreamPageStmt+  case auditMode of+    AuditFull ->+      runTransaction+        $ Tx.statement+          (category, cursor, Prelude.fromIntegral limit)+          fullStreamPageStmt+    AuditTargeted affected ->+      runTransaction+        $ Tx.statement+          ( category,+            eventTypeTexts affected,+            affected ^. #includeSnapshotStreams,+            cursor,+            Prelude.fromIntegral limit+          )+          targetedStreamPageStmt  eventTypeTexts :: AffectedSet -> Vector Text eventTypeTexts affected =-    Vector.fromList-        [ text-        | EventType text <- Set.toAscList (affected ^. #affectedEventTypes)-        ]+  Vector.fromList+    [ text+    | EventType text <- Set.toAscList (affected ^. #affectedEventTypes)+    ]  categoryStreamCountStmt :: Statement Text Int64 categoryStreamCountStmt =-    preparable-        """-        SELECT count(*)-        FROM kiroku.streams-        WHERE category = $1-          AND stream_version > 0-        """-        (E.param (E.nonNullable E.text))-        (D.singleRow (D.column (D.nonNullable D.int8)))+  preparable+    """+    SELECT count(*)+    FROM kiroku.streams+    WHERE category = $1+      AND stream_version > 0+    """+    (E.param (E.nonNullable E.text))+    (D.singleRow (D.column (D.nonNullable D.int8)))  fullStreamPageStmt :: Statement (Text, Int64, Int32) (Vector (StreamId, GlobalPosition)) fullStreamPageStmt =-    preparable-        """-        SELECT s.stream_id, max(all_events.stream_version) AS watermark-        FROM kiroku.streams s-        JOIN kiroku.stream_events all_events-          ON all_events.stream_id = 0-         AND all_events.original_stream_id = s.stream_id-        WHERE s.category = $1-        GROUP BY s.stream_id-        HAVING max(all_events.stream_version) > $2-        ORDER BY watermark ASC-        LIMIT $3-        """-        ( contrazip3-            (E.param (E.nonNullable E.text))-            (E.param (E.nonNullable E.int8))-            (E.param (E.nonNullable E.int4))-        )-        streamPageDecoder+  preparable+    """+    SELECT s.stream_id, max(all_events.stream_version) AS watermark+    FROM kiroku.streams s+    JOIN kiroku.stream_events all_events+      ON all_events.stream_id = 0+     AND all_events.original_stream_id = s.stream_id+    WHERE s.category = $1+    GROUP BY s.stream_id+    HAVING max(all_events.stream_version) > $2+    ORDER BY watermark ASC+    LIMIT $3+    """+    ( contrazip3+        (E.param (E.nonNullable E.text))+        (E.param (E.nonNullable E.int8))+        (E.param (E.nonNullable E.int4))+    )+    streamPageDecoder  targetedStreamCountStmt :: Statement (Text, Vector Text, Bool) Int64 targetedStreamCountStmt =-    preparable-        (targetedSelectionCte <> "SELECT count(*) FROM selected")-        targetedSelectionEncoder-        (D.singleRow (D.column (D.nonNullable D.int8)))+  preparable+    (targetedSelectionCte <> "SELECT count(*) FROM selected")+    targetedSelectionEncoder+    (D.singleRow (D.column (D.nonNullable D.int8)))  targetedStreamPageStmt ::-    Statement-        (Text, Vector Text, Bool, Int64, Int32)-        (Vector (StreamId, GlobalPosition))+  Statement+    (Text, Vector Text, Bool, Int64, Int32)+    (Vector (StreamId, GlobalPosition)) targetedStreamPageStmt =-    preparable-        ( targetedSelectionCte-            <> """-               SELECT stream_id, watermark-               FROM selected-               WHERE watermark > $4-               ORDER BY watermark ASC-               LIMIT $5-               """-        )-        ( contrazip5-            (E.param (E.nonNullable E.text))-            (E.param (E.nonNullable (E.foldableArray (E.nonNullable E.text))))-            (E.param (E.nonNullable E.bool))-            (E.param (E.nonNullable E.int8))-            (E.param (E.nonNullable E.int4))-        )-        streamPageDecoder--targetedSelectionEncoder :: E.Params (Text, Vector Text, Bool)-targetedSelectionEncoder =-    contrazip3+  preparable+    ( targetedSelectionCte+        <> """+           SELECT stream_id, watermark+           FROM selected+           WHERE watermark > $4+           ORDER BY watermark ASC+           LIMIT $5+           """+    )+    ( contrazip5         (E.param (E.nonNullable E.text))         (E.param (E.nonNullable (E.foldableArray (E.nonNullable E.text))))         (E.param (E.nonNullable E.bool))+        (E.param (E.nonNullable E.int8))+        (E.param (E.nonNullable E.int4))+    )+    streamPageDecoder +targetedSelectionEncoder :: E.Params (Text, Vector Text, Bool)+targetedSelectionEncoder =+  contrazip3+    (E.param (E.nonNullable E.text))+    (E.param (E.nonNullable (E.foldableArray (E.nonNullable E.text))))+    (E.param (E.nonNullable E.bool))+ targetedSelectionCte :: Text targetedSelectionCte =-    """-    WITH candidate_streams AS (-      SELECT DISTINCT s.stream_id-      FROM kiroku.streams s-      JOIN kiroku.stream_events source_events-        ON source_events.stream_id = 0-       AND source_events.original_stream_id = s.stream_id-      JOIN kiroku.events e ON e.event_id = source_events.event_id-      WHERE s.category = $1-        AND e.event_type = ANY($2::text[])-      UNION-      SELECT s.stream_id-      FROM kiroku.streams s-      JOIN keiro.keiro_snapshots snapshots ON snapshots.stream_id = s.stream_id-      WHERE $3-        AND s.category = $1-    ),-    selected AS (-      SELECT candidates.stream_id, max(all_events.stream_version) AS watermark-      FROM candidate_streams candidates-      JOIN kiroku.stream_events all_events-        ON all_events.stream_id = 0-       AND all_events.original_stream_id = candidates.stream_id-      GROUP BY candidates.stream_id-    )-    """+  """+  WITH candidate_streams AS (+    SELECT DISTINCT s.stream_id+    FROM kiroku.streams s+    JOIN kiroku.stream_events source_events+      ON source_events.stream_id = 0+     AND source_events.original_stream_id = s.stream_id+    JOIN kiroku.events e ON e.event_id = source_events.event_id+    WHERE s.category = $1+      AND e.event_type = ANY($2::text[])+    UNION+    SELECT s.stream_id+    FROM kiroku.streams s+    JOIN keiro.keiro_snapshots snapshots ON snapshots.stream_id = s.stream_id+    WHERE $3+      AND s.category = $1+  ),+  selected AS (+    SELECT candidates.stream_id, max(all_events.stream_version) AS watermark+    FROM candidate_streams candidates+    JOIN kiroku.stream_events all_events+      ON all_events.stream_id = 0+     AND all_events.original_stream_id = candidates.stream_id+    GROUP BY candidates.stream_id+  )+  """  streamPageDecoder :: D.Result (Vector (StreamId, GlobalPosition)) streamPageDecoder =-    D.rowVector-        $ (,)-        <$> (StreamId <$> D.column (D.nonNullable D.int8))-        <*> (GlobalPosition <$> D.column (D.nonNullable D.int8))+  D.rowVector+    $ (,)+    <$> (StreamId <$> D.column (D.nonNullable D.int8))+    <*> (GlobalPosition <$> D.column (D.nonNullable D.int8))
src/Keiro/ReplayDigest.hs view
@@ -1,15 +1,15 @@-{- | Stable canonical encodings and SHA-256 digests for replay comparisons.--Canonicalization is Aeson's RFC 8785 implementation. Hashing is the maintained-@cryptohash-sha256@ implementation of FIPS 180-4, and hexadecimal rendering is-@base16-bytestring@'s RFC 4648 encoder. Correctness comparisons still use the-canonical bytes directly; the digest is their compact operator-facing-identifier.--}-module Keiro.ReplayDigest (-    canonicalJsonBytes,+-- | Stable canonical encodings and SHA-256 digests for replay comparisons.+--+-- Canonicalization is Aeson's RFC 8785 implementation. Hashing is the maintained+-- @cryptohash-sha256@ implementation of FIPS 180-4, and hexadecimal rendering is+-- @base16-bytestring@'s RFC 4648 encoder. Correctness comparisons still use the+-- canonical bytes directly; the digest is their compact operator-facing+-- identifier.+module Keiro.ReplayDigest+  ( canonicalJsonBytes,     replayDigest,-) where+  )+where  import Crypto.Hash.SHA256 qualified as SHA256 import Data.Aeson.RFC8785 qualified as RFC8785@@ -26,7 +26,7 @@ -- | SHA-256 over RFC 8785 canonical JSON, rendered as lower-case hexadecimal. replayDigest :: Value -> Text replayDigest =-    Text.decodeUtf8-        . Base16.encode-        . SHA256.hash-        . canonicalJsonBytes+  Text.decodeUtf8+    . Base16.encode+    . SHA256.hash+    . canonicalJsonBytes
src/Keiro/Router.hs view
@@ -1,34 +1,33 @@-{- | Stateless, content-based routing of events to commands.--A 'Router' is the stateless sibling of-'Keiro.ProcessManager.ProcessManager': for each incoming event it resolves-a data-dependent set of target streams /effectfully/ (typically via a-read-model query) and dispatches one command to each. Dispatch is-idempotent per resolved target identity: every command is appended under a-target-name-keyed deterministic id, and store-level duplicate rejections are-confirmed against that target before becoming a benign-'PMCommandDuplicate'. Redelivery therefore deduplicates every target resolved-again, regardless of target order. Because resolution is effectful, the target-set may drift between attempts; dispatches accumulate as the union of those-attempts, so callers that require one exact set must keep resolution stable for-a source event.--Use 'runRouterOnce' to dispatch a single event, or 'runRouterWorker' to run-the router as a live subscription draining a Shibuya adapter. Its retry and-source-event dead-letter contract is the same bounded Kiroku contract described-by "Keiro.ProcessManager": five total deliveries by default, followed by a-@kiroku.dead_letters@ write and atomic checkpoint advance.--A router's 'key' can join events from different source streams just as a-process manager's @correlate@ function can. The same ordering rule applies:-same-stream order is preserved, but different streams have no relative-business-order guarantee and may run concurrently under sharding. Keep routed-logic order-insensitive; see "Keiro.ProcessManager" for the worked example.-Each resolved target command (with its inline projections) commits in its own-transaction, so fan-out is idempotent rather than all-target atomic.--}-module Keiro.Router (-    -- * Definition+-- | Stateless, content-based routing of events to commands.+--+-- A 'Router' is the stateless sibling of+-- 'Keiro.ProcessManager.ProcessManager': for each incoming event it resolves+-- a data-dependent set of target streams /effectfully/ (typically via a+-- read-model query) and dispatches one command to each. Dispatch is+-- idempotent per resolved target identity: every command is appended under a+-- target-name-keyed deterministic id, and store-level duplicate rejections are+-- confirmed against that target before becoming a benign+-- 'PMCommandDuplicate'. Redelivery therefore deduplicates every target resolved+-- again, regardless of target order. Because resolution is effectful, the target+-- set may drift between attempts; dispatches accumulate as the union of those+-- attempts, so callers that require one exact set must keep resolution stable for+-- a source event.+--+-- Use 'runRouterOnce' to dispatch a single event, or 'runRouterWorker' to run+-- the router as a live subscription draining a Shibuya adapter. Its retry and+-- source-event dead-letter contract is the same bounded Kiroku contract described+-- by "Keiro.ProcessManager": five total deliveries by default, followed by a+-- @kiroku.dead_letters@ write and atomic checkpoint advance.+--+-- A router's 'key' can join events from different source streams just as a+-- process manager's @correlate@ function can. The same ordering rule applies:+-- same-stream order is preserved, but different streams have no relative+-- business-order guarantee and may run concurrently under sharding. Keep routed+-- logic order-insensitive; see "Keiro.ProcessManager" for the worked example.+-- Each resolved target command (with its inline projections) commits in its own+-- transaction, so fan-out is idempotent rather than all-target atomic.+module Keiro.Router+  ( -- * Definition     Router (..),     RouterResult (..), @@ -39,7 +38,7 @@     runRouterOnce,     runRouterWorkerWith,     runRouterWorker,-)+  ) where  import Data.ByteString qualified as ByteString@@ -60,8 +59,8 @@ import Keiro.EventStream (EventStream) import Keiro.EventStream.Validate (ValidatedEventStream, unvalidated) import Keiro.Prelude-import Keiro.ProcessManager (-    DispatchFailure (..),+import Keiro.ProcessManager+  ( DispatchFailure (..),     PMCommand (..),     PMCommandResult (..),     PoisonPolicy (..),@@ -72,7 +71,7 @@     defaultWorkerOptions,     deterministicCommandId,     eventAlreadyIn,- )+  ) import Keiro.Projection (InlineProjection, runCommandWithProjections) import Keiro.Stream (Stream) import Keiro.Telemetry (recordDispatchDuplicate, recordDispatchFailed, recordDispatchPoison)@@ -89,337 +88,330 @@ import Streamly.Data.Stream qualified as Streamly import Prelude (filter, fromIntegral, length, snd, zip, (+)) -{- | A stateless, content-based router (in the Enterprise Integration Patterns-sense): for each incoming event it resolves a data-dependent set of target-streams /effectfully/ and dispatches one command to each.--This is the stateless counterpart of 'Keiro.ProcessManager.ProcessManager'. It-has no manager state stream, no @correlate@, and no self-directed command. Its-sole new capability over the process manager is that target resolution runs in-@Eff es@ — typically a read-model query via 'Keiro.ReadModel.runQuery' — so the-fan-out set can be /looked up/ rather than computed purely from the event.--Dispatch is idempotent by construction: each target command is appended under a-deterministic identifier derived from @(name, key input, source event id,-resolved target stream name, occurrence)@ (see-'deterministicRouterCommandId'), pre-checked with 'eventAlreadyIn', and the-store's @DuplicateEvent@ rejection is confirmed against the target stream-before it is treated as benign. A redelivery deduplicates every target it-resolves again even if target order or membership changed. A target resolved-only on an earlier attempt keeps its immutable dispatch, and a newly resolved-target is dispatched on the later attempt; the cumulative set is therefore the-union of attempt outputs. Keep 'resolve' stable for a source event when the-exact recipient set matters.--Each dispatch also runs 'targetProjections' for the target aggregate in the same-append transaction. The function receives the concrete target stream so callers can-build projections closed over stream-local keys. Return @[]@ to preserve-append-only dispatch.--}+-- | A stateless, content-based router (in the Enterprise Integration Patterns+-- sense): for each incoming event it resolves a data-dependent set of target+-- streams /effectfully/ and dispatches one command to each.+--+-- This is the stateless counterpart of 'Keiro.ProcessManager.ProcessManager'. It+-- has no manager state stream, no @correlate@, and no self-directed command. Its+-- sole new capability over the process manager is that target resolution runs in+-- @Eff es@ — typically a read-model query via 'Keiro.ReadModel.runQuery' — so the+-- fan-out set can be /looked up/ rather than computed purely from the event.+--+-- Dispatch is idempotent by construction: each target command is appended under a+-- deterministic identifier derived from @(name, key input, source event id,+-- resolved target stream name, occurrence)@ (see+-- 'deterministicRouterCommandId'), pre-checked with 'eventAlreadyIn', and the+-- store's @DuplicateEvent@ rejection is confirmed against the target stream+-- before it is treated as benign. A redelivery deduplicates every target it+-- resolves again even if target order or membership changed. A target resolved+-- only on an earlier attempt keeps its immutable dispatch, and a newly resolved+-- target is dispatched on the later attempt; the cumulative set is therefore the+-- union of attempt outputs. Keep 'resolve' stable for a source event when the+-- exact recipient set matters.+--+-- Each dispatch also runs 'targetProjections' for the target aggregate in the same+-- append transaction. The function receives the concrete target stream so callers can+-- build projections closed over stream-local keys. Return @[]@ to preserve+-- append-only dispatch. data Router input targetPhi targetRs targetState targetCi targetCo es = Router-    { name :: !Text-    -- ^ Stable identifier; part of every dispatched command's deterministic id.-    , key :: !(input -> Text)-    -- ^ Correlation string for the source event (e.g. the transaction id).-    , resolve :: !(input -> Eff es [PMCommand targetCi])-    {- ^ The effectful seam: compute the data-dependent target set, typically-    @runQuery readModel q@.-    -}-    , targetEventStream :: !(ValidatedEventStream targetPhi targetRs targetState targetCi targetCo)-    -- ^ The aggregate every resolved command is dispatched to.-    , targetProjections :: !(Stream targetCi -> [InlineProjection targetCo])-    {- ^ Inline projections for the target aggregate, run in the same transaction-    as each dispatched command's append. Return @[]@ for append-only dispatch.-    -}-    }-    deriving stock (Generic)--{- | The outcome of a single 'runRouterOnce' invocation: one-'PMCommandResult' per resolved target, in resolution order.+  { -- | Stable identifier; part of every dispatched command's deterministic id.+    name :: !Text,+    -- | Correlation string for the source event (e.g. the transaction id).+    key :: !(input -> Text),+    -- | The effectful seam: compute the data-dependent target set, typically+    --     @runQuery readModel q@.+    resolve :: !(input -> Eff es [PMCommand targetCi]),+    -- | The aggregate every resolved command is dispatched to.+    targetEventStream :: !(ValidatedEventStream targetPhi targetRs targetState targetCi targetCo),+    -- | Inline projections for the target aggregate, run in the same transaction+    --     as each dispatched command's append. Return @[]@ for append-only dispatch.+    targetProjections :: !(Stream targetCi -> [InlineProjection targetCo])+  }+  deriving stock (Generic) -Unlike 'Keiro.ProcessManager.ProcessManagerResult' there is no manager-state-result, because a router has no state stream. A failed dispatch surfaces as a-'PMCommandFailed' element rather than an outer 'Either'.--}+-- | The outcome of a single 'runRouterOnce' invocation: one+-- 'PMCommandResult' per resolved target, in resolution order.+--+-- Unlike 'Keiro.ProcessManager.ProcessManagerResult' there is no manager-state+-- result, because a router has no state stream. A failed dispatch surfaces as a+-- 'PMCommandFailed' element rather than an outer 'Either'. newtype RouterResult target = RouterResult-    { commandResults :: [PMCommandResult target]-    }-    deriving stock (Generic, Eq, Show)--{- | Derive a stable, collision-resistant 'EventId' for a router dispatch from-@(router name, key input, source event id, resolved target stream name,-occurrence)@ via a v5 UUID.--Unlike 'Keiro.ProcessManager.deterministicCommandId' (which the process manager-still uses, soundly, because its command list is a pure function of the input),-the router keys the id by the target's identity rather than its position in the-resolved list: 'resolve' is effectful, so a redelivery may see the same targets-in a different order or a drifted set, and a positional id would then point at-the wrong target. The @occurrence@ is the index among commands in the same-resolve batch that address the same target stream (0 for the first), so-resolving the same target twice in one batch still yields distinct ids.+  { commandResults :: [PMCommandResult target]+  }+  deriving stock (Generic, Eq, Show) -The v5 name encodes every text field as length-prefixed UTF-8. This avoids both-delimiter ambiguity when names contain colons and character truncation for-non-ASCII names.--}+-- | Derive a stable, collision-resistant 'EventId' for a router dispatch from+-- @(router name, key input, source event id, resolved target stream name,+-- occurrence)@ via a v5 UUID.+--+-- Unlike 'Keiro.ProcessManager.deterministicCommandId' (which the process manager+-- still uses, soundly, because its command list is a pure function of the input),+-- the router keys the id by the target's identity rather than its position in the+-- resolved list: 'resolve' is effectful, so a redelivery may see the same targets+-- in a different order or a drifted set, and a positional id would then point at+-- the wrong target. The @occurrence@ is the index among commands in the same+-- resolve batch that address the same target stream (0 for the first), so+-- resolving the same target twice in one batch still yields distinct ids.+--+-- The v5 name encodes every text field as length-prefixed UTF-8. This avoids both+-- delimiter ambiguity when names contain colons and character truncation for+-- non-ASCII names. deterministicRouterCommandId :: Text -> Text -> EventId -> StreamName -> Int -> EventId deterministicRouterCommandId routerName correlationId sourceEventId targetStreamName occurrence =-    EventId-        $ UUID.V5.generateNamed UUID.V5.namespaceURL-        $ ByteString.unpack-        $ ByteString.concat-        $ fmap-            encodeField-            [ "keiro"-            , "router"-            , routerName-            , correlationId-            , UUID.toText (coerce sourceEventId)-            , coerce targetStreamName-            , Text.pack (show occurrence)-            ]+  EventId+    $ UUID.V5.generateNamed UUID.V5.namespaceURL+    $ ByteString.unpack+    $ ByteString.concat+    $ fmap+      encodeField+      [ "keiro",+        "router",+        routerName,+        correlationId,+        UUID.toText (coerce sourceEventId),+        coerce targetStreamName,+        Text.pack (show occurrence)+      ]   where     encodeField field =-        let bytes = Text.Encoding.encodeUtf8 field-         in ByteString.concat-                [ ByteString.Char8.pack (show (ByteString.length bytes))-                , ByteString.singleton 58-                , bytes-                ]--{- | Resolve the targets for one source event, then dispatch one command per-target with crash-safe, target-identity idempotency.--Unlike 'Keiro.ProcessManager.runProcessManagerOnce', whose pure command list-can safely use positional ids, a router derives each id from the resolved-target stream name and its same-stream occurrence. It skips ids already in the-target stream, otherwise runs 'Keiro.Projection.runCommandWithProjections', and-folds a @DuplicateEvent@ rejection only after confirming the attempted id is in-that target stream.+      let bytes = Text.Encoding.encodeUtf8 field+       in ByteString.concat+            [ ByteString.Char8.pack (show (ByteString.length bytes)),+              ByteString.singleton 58,+              bytes+            ] -Returns 'RouterResult' directly (no outer @Either CommandError@) because — unlike-the process manager — there is no manager-state append that can fail before-dispatch.--}+-- | Resolve the targets for one source event, then dispatch one command per+-- target with crash-safe, target-identity idempotency.+--+-- Unlike 'Keiro.ProcessManager.runProcessManagerOnce', whose pure command list+-- can safely use positional ids, a router derives each id from the resolved+-- target stream name and its same-stream occurrence. It skips ids already in the+-- target stream, otherwise runs 'Keiro.Projection.runCommandWithProjections', and+-- folds a @DuplicateEvent@ rejection only after confirming the attempted id is in+-- that target stream.+--+-- Returns 'RouterResult' directly (no outer @Either CommandError@) because — unlike+-- the process manager — there is no manager-state append that can fail before+-- dispatch. runRouterOnce ::-    forall input targetPhi targetRs targetState targetCi targetCo es.-    ( HasCallStack-    , IOE :> es-    , Store :> es-    , Error StoreError :> es-    , KirokuStoreResource :> es-    , BoolAlg targetPhi (RegFile targetRs, targetCi)-    , Eq targetCo-    ) =>-    RunCommandOptions ->-    Router input targetPhi targetRs targetState targetCi targetCo es ->-    RecordedEvent ->-    input ->-    Eff es (RouterResult (EventStream targetPhi targetRs targetState targetCi targetCo))+  forall input targetPhi targetRs targetState targetCi targetCo es.+  ( HasCallStack,+    IOE :> es,+    Store :> es,+    Error StoreError :> es,+    KirokuStoreResource :> es,+    BoolAlg targetPhi (RegFile targetRs, targetCi),+    Eq targetCo+  ) =>+  RunCommandOptions ->+  Router input targetPhi targetRs targetState targetCi targetCo es ->+  RecordedEvent ->+  input ->+  Eff es (RouterResult (EventStream targetPhi targetRs targetState targetCi targetCo)) runRouterOnce options router sourceEvent input = do-    let correlationId = (router ^. #key) input-    commands <- (router ^. #resolve) input-    let named =-            [ (streamNameOf command, command)-            | command <- commands-            ]-        annotated = snd (mapAccumL occurrenceStep Map.empty (zip [0 ..] named))-        occurrenceStep seen (legacyIndex, (targetStreamName, command)) =-            let occurrence = Map.findWithDefault 0 targetStreamName seen-             in ( Map.insert targetStreamName (occurrence + 1) seen-                , (legacyIndex, occurrence, targetStreamName, command)-                )-    results <--        traverse-            (dispatchCommand correlationId (sourceEvent ^. #eventId))-            annotated-    pure (RouterResult results)+  let correlationId = (router ^. #key) input+  commands <- (router ^. #resolve) input+  let named =+        [ (streamNameOf command, command)+        | command <- commands+        ]+      annotated = snd (mapAccumL occurrenceStep Map.empty (zip [0 ..] named))+      occurrenceStep seen (legacyIndex, (targetStreamName, command)) =+        let occurrence = Map.findWithDefault 0 targetStreamName seen+         in ( Map.insert targetStreamName (occurrence + 1) seen,+              (legacyIndex, occurrence, targetStreamName, command)+            )+  results <-+    traverse+      (dispatchCommand correlationId (sourceEvent ^. #eventId))+      annotated+  pure (RouterResult results)   where     streamNameOf command =-        ((unvalidated (router ^. #targetEventStream)) ^. #resolveStreamName)-            (retarget (command ^. #target))+      ((unvalidated (router ^. #targetEventStream)) ^. #resolveStreamName)+        (retarget (command ^. #target))      dispatchCommand correlationId sourceEventId (legacyIndex, occurrence, targetStreamName, command) = do-        let commandId =-                deterministicRouterCommandId-                    (router ^. #name)-                    correlationId-                    sourceEventId-                    targetStreamName-                    occurrence-            -- Transition: dispatches written by keiro versions that derived-            -- positional ids must still dedup across the upgrade. Remove in a-            -- later release after the compatibility window closes.-            legacyCommandId =-                deterministicCommandId-                    (router ^. #name)-                    correlationId-                    sourceEventId-                    legacyIndex-            targetOptions = options & #eventIds .~ [commandId]-            targetEventStream = router ^. #targetEventStream-            targetStream = retarget (command ^. #target)-        commandAlreadyProcessed <- eventAlreadyIn options targetStreamName commandId-        legacyAlreadyProcessed <--            if commandAlreadyProcessed-                then pure False-                else eventAlreadyIn options targetStreamName legacyCommandId+      let commandId =+            deterministicRouterCommandId+              (router ^. #name)+              correlationId+              sourceEventId+              targetStreamName+              occurrence+          -- Transition: dispatches written by keiro versions that derived+          -- positional ids must still dedup across the upgrade. Remove in a+          -- later release after the compatibility window closes.+          legacyCommandId =+            deterministicCommandId+              (router ^. #name)+              correlationId+              sourceEventId+              legacyIndex+          targetOptions = options & #eventIds .~ [commandId]+          targetEventStream = router ^. #targetEventStream+          targetStream = retarget (command ^. #target)+      commandAlreadyProcessed <- eventAlreadyIn options targetStreamName commandId+      legacyAlreadyProcessed <-         if commandAlreadyProcessed-            then pure (PMCommandDuplicate commandId)-            else-                if legacyAlreadyProcessed-                    then pure (PMCommandDuplicate legacyCommandId)-                    else do-                        outcome <--                            runCommandWithProjections-                                targetOptions-                                targetEventStream-                                targetStream-                                (command ^. #command)-                                ((router ^. #targetProjections) (command ^. #target))-                        case outcome of-                            Right result -> pure (PMCommandAppended result)-                            Left err -> do-                                benign <- confirmBenignDuplicate targetStreamName commandId err-                                pure $ if benign then PMCommandDuplicate commandId else PMCommandFailed targetStreamName err+          then pure False+          else eventAlreadyIn options targetStreamName legacyCommandId+      if commandAlreadyProcessed+        then pure (PMCommandDuplicate commandId)+        else+          if legacyAlreadyProcessed+            then pure (PMCommandDuplicate legacyCommandId)+            else do+              outcome <-+                runCommandWithProjections+                  targetOptions+                  targetEventStream+                  targetStream+                  (command ^. #command)+                  ((router ^. #targetProjections) (command ^. #target))+              case outcome of+                Right result -> pure (PMCommandAppended result)+                Left err -> do+                  benign <- confirmBenignDuplicate targetStreamName commandId err+                  pure $ if benign then PMCommandDuplicate commandId else PMCommandFailed targetStreamName err      retarget :: Stream targetCi -> Stream (EventStream targetPhi targetRs targetState targetCi targetCo)     retarget = coerce -{- | Run a 'Router' as a live subscription over a Shibuya 'Adapter'.--Mirrors 'Keiro.ProcessManager.runProcessManagerWorker': it drains the adapter's-message stream, decoding each message to a @(RecordedEvent, input)@ pair and-dispatching it through 'runRouterOnce'.--Ack policy (see this plan's Decision Log):--  * a message that fails to decode follows the configured 'PoisonPolicy'-    (default: 'AckHalt' @HaltFatal@);-  * otherwise, after dispatch, if every 'PMCommandResult' is-    'PMCommandAppended' or 'PMCommandDuplicate' the message finalizes 'AckOk';-  * if any dispatch is 'PMCommandFailed', transient failures finalize-    'AckRetry', systemic deterministic failures finalize @AckHalt-    (HaltFatal …)@, and rejection-class failures follow-    'RejectedCommandPolicy'.--Benign domain rejections (a target aggregate refusing a "check" command because-no edge matches) must be modeled as /total/ transitions in the keiki transducer-(an ε-complement self-loop) so they never surface as 'PMCommandFailed' and-therefore never wedge the worker. When the rejection is genuinely-data-dependent, 'RejectedDeadLetter' persists a queryable-"Keiro.DeadLetter.DispatchDeadLetter" and acknowledges the source event;-'RejectedSkip' acknowledges and records only the metric. 'RejectedHalt' remains-the default.--The worker invokes each ingested message's 'Shibuya.Core.AckHandle.AckHandle'-@finalize@ exactly once with the decision, so the decision reaches the adapter.-Use 'runRouterWorkerWith' to override poison-message handling, rejected-command-handling, transient retry delay, or dispatch metrics. On a Kiroku-backed-adapter, 'AckRetry' remains bounded by the subscription @RetryPolicy@ (five-total deliveries by default). Exhaustion records the source event in-@kiroku.dead_letters@ with reason kind @max_attempts_exceeded@ and advances the-checkpoint. @KirokuAdapterConfig@ does not currently expose @retryPolicy@;-install 'Keiro.Telemetry.kirokuEventBridge' on Kiroku's @eventHandler@ to observe-the terminal event. The configurable sharded path forwards-@ShardedWorkerOptions.retryPolicy@ through the same Kiroku ladder; see-"Keiro.Subscription.Shard.Worker".--}+-- | Run a 'Router' as a live subscription over a Shibuya 'Adapter'.+--+-- Mirrors 'Keiro.ProcessManager.runProcessManagerWorker': it drains the adapter's+-- message stream, decoding each message to a @(RecordedEvent, input)@ pair and+-- dispatching it through 'runRouterOnce'.+--+-- Ack policy (see this plan's Decision Log):+--+--   * a message that fails to decode follows the configured 'PoisonPolicy'+--     (default: 'AckHalt' @HaltFatal@);+--   * otherwise, after dispatch, if every 'PMCommandResult' is+--     'PMCommandAppended' or 'PMCommandDuplicate' the message finalizes 'AckOk';+--   * if any dispatch is 'PMCommandFailed', transient failures finalize+--     'AckRetry', systemic deterministic failures finalize @AckHalt+--     (HaltFatal …)@, and rejection-class failures follow+--     'RejectedCommandPolicy'.+--+-- Benign domain rejections (a target aggregate refusing a "check" command because+-- no edge matches) must be modeled as /total/ transitions in the keiki transducer+-- (an ε-complement self-loop) so they never surface as 'PMCommandFailed' and+-- therefore never wedge the worker. When the rejection is genuinely+-- data-dependent, 'RejectedDeadLetter' persists a queryable+-- "Keiro.DeadLetter.DispatchDeadLetter" and acknowledges the source event;+-- 'RejectedSkip' acknowledges and records only the metric. 'RejectedHalt' remains+-- the default.+--+-- The worker invokes each ingested message's 'Shibuya.Core.AckHandle.AckHandle'+-- @finalize@ exactly once with the decision, so the decision reaches the adapter.+-- Use 'runRouterWorkerWith' to override poison-message handling, rejected-command+-- handling, transient retry delay, or dispatch metrics. On a Kiroku-backed+-- adapter, 'AckRetry' remains bounded by the subscription @RetryPolicy@ (five+-- total deliveries by default). Exhaustion records the source event in+-- @kiroku.dead_letters@ with reason kind @max_attempts_exceeded@ and advances the+-- checkpoint. @KirokuAdapterConfig@ does not currently expose @retryPolicy@;+-- install 'Keiro.Telemetry.kirokuEventBridge' on Kiroku's @eventHandler@ to observe+-- the terminal event. The configurable sharded path forwards+-- @ShardedWorkerOptions.retryPolicy@ through the same Kiroku ladder; see+-- "Keiro.Subscription.Shard.Worker". runRouterWorker ::-    forall msg input targetPhi targetRs targetState targetCi targetCo es.-    ( HasCallStack-    , IOE :> es-    , Store :> es-    , Error StoreError :> es-    , KirokuStoreResource :> es-    , BoolAlg targetPhi (RegFile targetRs, targetCi)-    , Eq targetCo-    ) =>-    RunCommandOptions ->-    Router input targetPhi targetRs targetState targetCi targetCo es ->-    Adapter es msg ->-    (msg -> Maybe (RecordedEvent, input)) ->-    Eff es ()+  forall msg input targetPhi targetRs targetState targetCi targetCo es.+  ( HasCallStack,+    IOE :> es,+    Store :> es,+    Error StoreError :> es,+    KirokuStoreResource :> es,+    BoolAlg targetPhi (RegFile targetRs, targetCi),+    Eq targetCo+  ) =>+  RunCommandOptions ->+  Router input targetPhi targetRs targetState targetCi targetCo es ->+  Adapter es msg ->+  (msg -> Maybe (RecordedEvent, input)) ->+  Eff es () runRouterWorker =-    runRouterWorkerWith defaultWorkerOptions+  runRouterWorkerWith defaultWorkerOptions  runRouterWorkerWith ::-    forall msg input targetPhi targetRs targetState targetCi targetCo es.-    ( HasCallStack-    , IOE :> es-    , Store :> es-    , Error StoreError :> es-    , KirokuStoreResource :> es-    , BoolAlg targetPhi (RegFile targetRs, targetCi)-    , Eq targetCo-    ) =>-    WorkerOptions es msg ->-    RunCommandOptions ->-    Router input targetPhi targetRs targetState targetCi targetCo es ->-    Adapter es msg ->-    (msg -> Maybe (RecordedEvent, input)) ->-    Eff es ()-runRouterWorkerWith workerOptions options router Adapter{source = adapterSource} decodeMessage =-    Streamly.fold Fold.drain-        $ Streamly.mapM handleIngested adapterSource+  forall msg input targetPhi targetRs targetState targetCi targetCo es.+  ( HasCallStack,+    IOE :> es,+    Store :> es,+    Error StoreError :> es,+    KirokuStoreResource :> es,+    BoolAlg targetPhi (RegFile targetRs, targetCi),+    Eq targetCo+  ) =>+  WorkerOptions es msg ->+  RunCommandOptions ->+  Router input targetPhi targetRs targetState targetCi targetCo es ->+  Adapter es msg ->+  (msg -> Maybe (RecordedEvent, input)) ->+  Eff es ()+runRouterWorkerWith workerOptions options router Adapter {source = adapterSource} decodeMessage =+  Streamly.fold Fold.drain+    $ Streamly.mapM handleIngested adapterSource   where     handleIngested :: Ingested es msg -> Eff es AckDecision-    handleIngested Ingested{envelope = env@Envelope{payload = message}, ack = AckHandle finalizeAck} = do-        decision <- case decodeMessage message of-            Nothing -> decideForPoison "router worker could not decode message" env-            Just (recorded, input) -> do-                let correlationId = (router ^. #key) input-                    attemptCount = envelopeAttemptCount env-                outcome <- tryError @StoreError (runRouterOnce options router recorded input)-                case outcome of-                    Left (_, storeErr) -> do-                        recordDispatchFailed (workerOptions ^. #metrics) 1-                        pure (ackForCommandError (workerOptions ^. #transientRetryDelay) (StoreFailed storeErr))-                    Right (RouterResult results) -> ackDecisionFor recorded correlationId attemptCount results-        finalizeAck decision-        pure decision+    handleIngested Ingested {envelope = env@Envelope {payload = message}, ack = AckHandle finalizeAck} = do+      decision <- case decodeMessage message of+        Nothing -> decideForPoison "router worker could not decode message" env+        Just (recorded, input) -> do+          let correlationId = (router ^. #key) input+              attemptCount = envelopeAttemptCount env+          outcome <- tryError @StoreError (runRouterOnce options router recorded input)+          case outcome of+            Left (_, storeErr) -> do+              recordDispatchFailed (workerOptions ^. #metrics) 1+              pure (ackForCommandError (workerOptions ^. #transientRetryDelay) (StoreFailed storeErr))+            Right (RouterResult results) -> ackDecisionFor recorded correlationId attemptCount results+      finalizeAck decision+      pure decision      ackDecisionFor :: RecordedEvent -> Text -> Int -> [PMCommandResult target] -> Eff es AckDecision     ackDecisionFor sourceEvent correlationId attemptCount results = do-        let duplicateCount = commandDuplicateCount results-            failures =-                [ DispatchFailure emitIndex targetStreamName err-                | (emitIndex, PMCommandFailed targetStreamName err) <- zip [0 ..] results-                ]-        recordDispatchDuplicate (workerOptions ^. #metrics) duplicateCount-        recordDispatchFailed (workerOptions ^. #metrics) (fromIntegral (length failures))-        decideForFailures-            workerOptions-            DispatcherRouter-            (router ^. #name)-            correlationId-            sourceEvent-            attemptCount-            failures+      let duplicateCount = commandDuplicateCount results+          failures =+            [ DispatchFailure emitIndex targetStreamName err+            | (emitIndex, PMCommandFailed targetStreamName err) <- zip [0 ..] results+            ]+      recordDispatchDuplicate (workerOptions ^. #metrics) duplicateCount+      recordDispatchFailed (workerOptions ^. #metrics) (fromIntegral (length failures))+      decideForFailures+        workerOptions+        DispatcherRouter+        (router ^. #name)+        correlationId+        sourceEvent+        attemptCount+        failures      commandDuplicateCount :: [PMCommandResult target] -> Int64     commandDuplicateCount =-        fromIntegral . length . filter isDuplicateResult+      fromIntegral . length . filter isDuplicateResult       where         isDuplicateResult = \case-            PMCommandDuplicate{} -> True-            _ -> False+          PMCommandDuplicate {} -> True+          _ -> False      decideForPoison :: Text -> Envelope msg -> Eff es AckDecision     decideForPoison reason env = do-        recordDispatchPoison (workerOptions ^. #metrics) 1-        case workerOptions ^. #poisonPolicy of-            PoisonHalt -> pure (AckHalt (HaltFatal reason))-            PoisonSkip callback -> do-                callback env-                pure AckOk-            PoisonDeadLetter callback -> do-                callback env-                pure (AckDeadLetter (InvalidPayload reason))+      recordDispatchPoison (workerOptions ^. #metrics) 1+      case workerOptions ^. #poisonPolicy of+        PoisonHalt -> pure (AckHalt (HaltFatal reason))+        PoisonSkip callback -> do+          callback env+          pure AckOk+        PoisonDeadLetter callback -> do+          callback env+          pure (AckDeadLetter (InvalidPayload reason))      envelopeAttemptCount :: Envelope msg -> Int     envelopeAttemptCount env =-        case env ^. #attempt of-            Nothing -> 1-            Just (Attempt attempt) -> fromIntegral attempt + 1+      case env ^. #attempt of+        Nothing -> 1+        Just (Attempt attempt) -> fromIntegral attempt + 1
src/Keiro/Snapshot.hs view
@@ -1,27 +1,26 @@-{- | Snapshots: skipping replay by persisting folded aggregate state.--A snapshot stores an aggregate's @(state, registers)@ at a known stream-version so hydration can start there instead of replaying the whole event-log. 'hydrateWithSnapshot' loads the latest compatible snapshot for a-stream (returning a 'SnapshotSeed' the command runner replays /forward/-from), and 'writeSnapshot' persists one after an append when the stream's-'Keiro.EventStream.SnapshotPolicy' fires.--Compatibility is gated by the version, register-file shape hash, and-control-state shape/fold hash of the 'StateCodec': a snapshot is only loaded-when all three match the current codec, so an incompatible encoding, register-layout, or folded-state interpretation transparently falls back to a full-replay. The JSON encoding lives in "Keiro.Snapshot.Codec" and the SQL storage-in "Keiro.Snapshot.Schema", both re-exported here.--Snapshot version non-regression applies only while all three discriminators-stay the same. A writer with any discriminant changed may replace a-higher-version row, allowing codec rollback to recover. In a mixed-version-deployment incompatible writers can therefore thrash the one row per stream-and repeatedly force full replay; this affects performance, not correctness.--}-module Keiro.Snapshot (-    -- * Hydration seed+-- | Snapshots: skipping replay by persisting folded aggregate state.+--+-- A snapshot stores an aggregate's @(state, registers)@ at a known stream+-- version so hydration can start there instead of replaying the whole event+-- log. 'hydrateWithSnapshot' loads the latest compatible snapshot for a+-- stream (returning a 'SnapshotSeed' the command runner replays /forward/+-- from), and 'writeSnapshot' persists one after an append when the stream's+-- 'Keiro.EventStream.SnapshotPolicy' fires.+--+-- Compatibility is gated by the version, register-file shape hash, and+-- control-state shape/fold hash of the 'StateCodec': a snapshot is only loaded+-- when all three match the current codec, so an incompatible encoding, register+-- layout, or folded-state interpretation transparently falls back to a full+-- replay. The JSON encoding lives in "Keiro.Snapshot.Codec" and the SQL storage+-- in "Keiro.Snapshot.Schema", both re-exported here.+--+-- Snapshot version non-regression applies only while all three discriminators+-- stay the same. A writer with any discriminant changed may replace a+-- higher-version row, allowing codec rollback to recover. In a mixed-version+-- deployment incompatible writers can therefore thrash the one row per stream+-- and repeatedly force full replay; this affects performance, not correctness.+module Keiro.Snapshot+  ( -- * Hydration seed     SnapshotSeed (..),     SnapshotMissReason (..),     SnapshotLookup (..),@@ -34,7 +33,7 @@     -- * State codec and storage     module Keiro.Snapshot.Codec,     module Keiro.Snapshot.Schema,-)+  ) where  import Control.DeepSeq (force)@@ -49,126 +48,120 @@ import Kiroku.Store.Read (lookupStreamId) import Kiroku.Store.Types (StreamId, StreamName, StreamVersion) -{- | A decoded snapshot the command runner replays forward from: the folded-'state' and 'registers' as of 'streamVersion'. Hydration reads only the-events after 'streamVersion' instead of the entire stream.--}+-- | A decoded snapshot the command runner replays forward from: the folded+-- 'state' and 'registers' as of 'streamVersion'. Hydration reads only the+-- events after 'streamVersion' instead of the entire stream. data SnapshotSeed rs s = SnapshotSeed-    { state :: !s-    , registers :: !(RegFile rs)-    , streamVersion :: !StreamVersion-    }-    deriving stock (Generic)+  { state :: !s,+    registers :: !(RegFile rs),+    streamVersion :: !StreamVersion+  }+  deriving stock (Generic)  -- | Why a snapshot lookup produced no usable hydration seed. data SnapshotMissReason-    = SnapshotNoStream-    | SnapshotNotFound-    | SnapshotDecodeFailed !Text-    deriving stock (Eq, Show, Generic)+  = SnapshotNoStream+  | SnapshotNotFound+  | SnapshotDecodeFailed !Text+  deriving stock (Eq, Show, Generic)  -- | The observable result of looking up and decoding an aggregate snapshot. data SnapshotLookup rs s-    = SnapshotUnavailable !SnapshotMissReason-    | SnapshotHit !(SnapshotSeed rs s)-    deriving stock (Generic)+  = SnapshotUnavailable !SnapshotMissReason+  | SnapshotHit !(SnapshotSeed rs s)+  deriving stock (Generic) -{- | Look up the latest compatible snapshot and retain the reason when no-usable seed exists. A matching row that fails to decode is distinguished from-a missing stream or row so callers can report the persistent fallback.--}+-- | Look up the latest compatible snapshot and retain the reason when no+-- usable seed exists. A matching row that fails to decode is distinguished from+-- a missing stream or row so callers can report the persistent fallback. lookupSnapshotSeed ::-    (Store :> es) =>-    StreamName ->-    StateCodec (s, RegFile rs) ->-    Eff es (SnapshotLookup rs s)+  (Store :> es) =>+  StreamName ->+  StateCodec (s, RegFile rs) ->+  Eff es (SnapshotLookup rs s) lookupSnapshotSeed streamName codec = do-    streamId <- lookupStreamId streamName-    case streamId of-        Nothing -> pure (SnapshotUnavailable SnapshotNoStream)-        Just foundStreamId -> do-            row <--                lookupSnapshot-                    foundStreamId-                    (codec ^. #stateCodecVersion)-                    (codec ^. #shapeHash)-                    (codec ^. #stateShapeHash)-            pure $ case row of-                Nothing -> SnapshotUnavailable SnapshotNotFound-                Just snapshot ->-                    case (codec ^. #decode) (snapshot ^. #state) of-                        Left message -> SnapshotUnavailable (SnapshotDecodeFailed message)-                        Right (state, registers) ->-                            SnapshotHit-                                SnapshotSeed-                                    { state = state-                                    , registers = registers-                                    , streamVersion = snapshot ^. #streamVersion-                                    }--{- | Load the latest snapshot compatible with @codec@ for the named stream.+  streamId <- lookupStreamId streamName+  case streamId of+    Nothing -> pure (SnapshotUnavailable SnapshotNoStream)+    Just foundStreamId -> do+      row <-+        lookupSnapshot+          foundStreamId+          (codec ^. #stateCodecVersion)+          (codec ^. #shapeHash)+          (codec ^. #stateShapeHash)+      pure $ case row of+        Nothing -> SnapshotUnavailable SnapshotNotFound+        Just snapshot ->+          case (codec ^. #decode) (snapshot ^. #state) of+            Left message -> SnapshotUnavailable (SnapshotDecodeFailed message)+            Right (state, registers) ->+              SnapshotHit+                SnapshotSeed+                  { state = state,+                    registers = registers,+                    streamVersion = snapshot ^. #streamVersion+                  } -Returns 'Nothing' — meaning "replay from the beginning" — when the stream-has no id yet, has no snapshot matching all three codec discriminators, or has-a snapshot whose bytes fail to decode. Decode failure is treated as a benign-miss rather than an error, so a corrupt or stale snapshot never blocks-hydration.--}+-- | Load the latest snapshot compatible with @codec@ for the named stream.+--+-- Returns 'Nothing' — meaning "replay from the beginning" — when the stream+-- has no id yet, has no snapshot matching all three codec discriminators, or has+-- a snapshot whose bytes fail to decode. Decode failure is treated as a benign+-- miss rather than an error, so a corrupt or stale snapshot never blocks+-- hydration. hydrateWithSnapshot ::-    (Store :> es) =>-    StreamName ->-    StateCodec (s, RegFile rs) ->-    Eff es (Maybe (SnapshotSeed rs s))+  (Store :> es) =>+  StreamName ->+  StateCodec (s, RegFile rs) ->+  Eff es (Maybe (SnapshotSeed rs s)) hydrateWithSnapshot streamName codec = do-    lookupSnapshotSeed streamName codec <&> \case-        SnapshotUnavailable _ -> Nothing-        SnapshotHit seed -> Just seed+  lookupSnapshotSeed streamName codec <&> \case+    SnapshotUnavailable _ -> Nothing+    SnapshotHit seed -> Just seed -{- | Strictly encode @state@ with @codec@, forcing the complete JSON value and-returning an 'ErrorCall' raised by a partial encoder or an uninitialized keiki-register. Other exception types deliberately remain visible to the caller.--}+-- | Strictly encode @state@ with @codec@, forcing the complete JSON value and+-- returning an 'ErrorCall' raised by a partial encoder or an uninitialized keiki+-- register. Other exception types deliberately remain visible to the caller. encodeSnapshotStrict :: StateCodec state -> state -> IO (Either ErrorCall Value) encodeSnapshotStrict codec state =-    try @ErrorCall (evaluate (force ((codec ^. #encode) state)))+  try @ErrorCall (evaluate (force ((codec ^. #encode) state))) -{- | Upsert a JSON value that has already been encoded and forced. Keeping this-separate from 'writeSnapshot' lets post-commit callers prove encoding is safe-before they touch the store. For fixed codec discriminators, stale versions-are ignored. Any changed discriminator may replace a higher-version row to-permit codec rollback; see the module header.--}+-- | Upsert a JSON value that has already been encoded and forced. Keeping this+-- separate from 'writeSnapshot' lets post-commit callers prove encoding is safe+-- before they touch the store. For fixed codec discriminators, stale versions+-- are ignored. Any changed discriminator may replace a higher-version row to+-- permit codec rollback; see the module header. writeSnapshotEncoded ::-    (Store :> es) =>-    StreamId ->-    StreamVersion ->-    StateCodec state ->-    Value ->-    Eff es ()+  (Store :> es) =>+  StreamId ->+  StreamVersion ->+  StateCodec state ->+  Value ->+  Eff es () writeSnapshotEncoded streamId streamVersion codec encoded =-    writeSnapshotRow-        SnapshotWrite-            { streamId = streamId-            , streamVersion = streamVersion-            , state = encoded-            , stateCodecVersion = codec ^. #stateCodecVersion-            , regfileShapeHash = codec ^. #shapeHash-            , stateShapeHash = codec ^. #stateShapeHash-            }+  writeSnapshotRow+    SnapshotWrite+      { streamId = streamId,+        streamVersion = streamVersion,+        state = encoded,+        stateCodecVersion = codec ^. #stateCodecVersion,+        regfileShapeHash = codec ^. #shapeHash,+        stateShapeHash = codec ^. #stateShapeHash+      } -{- | Encode @state@ with @codec@ and upsert it as the snapshot for the given-stream at @streamVersion@. This compatibility helper preserves the historical-lazy encoding behavior; post-commit advisory paths should call-'encodeSnapshotStrict' first and pass the result to 'writeSnapshotEncoded'. For-fixed codec discriminators stale writes are ignored, while an incompatible-codec may replace a newer row to permit rollback.--}+-- | Encode @state@ with @codec@ and upsert it as the snapshot for the given+-- stream at @streamVersion@. This compatibility helper preserves the historical+-- lazy encoding behavior; post-commit advisory paths should call+-- 'encodeSnapshotStrict' first and pass the result to 'writeSnapshotEncoded'. For+-- fixed codec discriminators stale writes are ignored, while an incompatible+-- codec may replace a newer row to permit rollback. writeSnapshot ::-    (Store :> es) =>-    StreamId ->-    StreamVersion ->-    StateCodec state ->-    state ->-    Eff es ()+  (Store :> es) =>+  StreamId ->+  StreamVersion ->+  StateCodec state ->+  state ->+  Eff es () writeSnapshot streamId streamVersion codec state =-    writeSnapshotEncoded streamId streamVersion codec ((codec ^. #encode) state)+  writeSnapshotEncoded streamId streamVersion codec ((codec ^. #encode) state)
src/Keiro/Snapshot/Codec.hs view
@@ -1,30 +1,29 @@-{- | The default JSON encoding for aggregate snapshots.--'defaultStateCodecWithFold' builds the recommended 'StateCodec' for a-hand-written service's @(state, registers)@ pair, serializing it as a JSON-object @{ "state": …, "registers": … }@ and composing a hand-owned-'FoldVersion' into the snapshot discriminator. Change the fold version in the-same edit that changes the service's event-folding behavior.--'defaultStateCodec' builds the underlying codec for the @(state, registers)@ pair-of a keiki machine, serializing it as a JSON object @{ "state": …,-"registers": … }@. The state half uses its 'ToJSON' \/ 'FromJSON'-instances; the register half uses keiki's register-file JSON encoding. The-codec derives separate hashes for the control-state shape and register-file-layout, so structural changes transparently invalidate older snapshots (see-"Keiro.Snapshot").--Generated services use 'withFoldFingerprint' directly with a fingerprint-derived from their spec. Hand-written guard and update function bodies are not-structurally inspectable, so hand-written services should use-'defaultStateCodecWithFold' and maintain its explicit 'FoldVersion'.--}-module Keiro.Snapshot.Codec (-    FoldVersion (..),+-- | The default JSON encoding for aggregate snapshots.+--+-- 'defaultStateCodecWithFold' builds the recommended 'StateCodec' for a+-- hand-written service's @(state, registers)@ pair, serializing it as a JSON+-- object @{ "state": …, "registers": … }@ and composing a hand-owned+-- 'FoldVersion' into the snapshot discriminator. Change the fold version in the+-- same edit that changes the service's event-folding behavior.+--+-- 'defaultStateCodec' builds the underlying codec for the @(state, registers)@ pair+-- of a keiki machine, serializing it as a JSON object @{ "state": …,+-- "registers": … }@. The state half uses its 'ToJSON' \/ 'FromJSON'+-- instances; the register half uses keiki's register-file JSON encoding. The+-- codec derives separate hashes for the control-state shape and register-file+-- layout, so structural changes transparently invalidate older snapshots (see+-- "Keiro.Snapshot").+--+-- Generated services use 'withFoldFingerprint' directly with a fingerprint+-- derived from their spec. Hand-written guard and update function bodies are not+-- structurally inspectable, so hand-written services should use+-- 'defaultStateCodecWithFold' and maintain its explicit 'FoldVersion'.+module Keiro.Snapshot.Codec+  ( FoldVersion (..),     defaultStateCodec,     defaultStateCodecWithFold,     withFoldFingerprint,-)+  ) where  import Data.Aeson (Result (..), object, withObject, (.:))@@ -38,99 +37,95 @@ import Keiro.EventStream (StateCodec (..)) import Keiro.Prelude -{- | A 'StateCodec' that serializes a @(state, registers)@ pair to a JSON-object, tagging it with the supplied codec version and hashes derived from the-control-state datatype and register-file layout.--This function does not identify changes to hand-written guards, register-updates, emitted outputs, targets, or helper functions used by the fold. Prefer-'defaultStateCodecWithFold' for hand-written services. Generated services use-'withFoldFingerprint' with a fingerprint derived from their spec.--}+-- | A 'StateCodec' that serializes a @(state, registers)@ pair to a JSON+-- object, tagging it with the supplied codec version and hashes derived from the+-- control-state datatype and register-file layout.+--+-- This function does not identify changes to hand-written guards, register+-- updates, emitted outputs, targets, or helper functions used by the fold. Prefer+-- 'defaultStateCodecWithFold' for hand-written services. Generated services use+-- 'withFoldFingerprint' with a fingerprint derived from their spec. defaultStateCodec ::-    forall rs s.-    (CanonicalStateShape s, FromJSON s, KnownRegFileShape rs, RegFileToJSON rs, ToJSON s) =>-    Int ->-    StateCodec (s, RegFile rs)+  forall rs s.+  (CanonicalStateShape s, FromJSON s, KnownRegFileShape rs, RegFileToJSON rs, ToJSON s) =>+  Int ->+  StateCodec (s, RegFile rs) defaultStateCodec version =-    StateCodec-        { stateCodecVersion = version-        , shapeHash = regFileShapeHash (Proxy @rs)-        , stateShapeHash = Shape.stateShapeHash (Proxy @s)-        , encode = \(state, registers) ->-            object-                [ "state" Aeson..= state-                , "registers" Aeson..= regFileToJSON registers-                ]-        , decode = decodeSnapshotValue-        }--{- | A hand-owned identity for a hand-written service's event fold.+  StateCodec+    { stateCodecVersion = version,+      shapeHash = regFileShapeHash (Proxy @rs),+      stateShapeHash = Shape.stateShapeHash (Proxy @s),+      encode = \(state, registers) ->+        object+          [ "state" Aeson..= state,+            "registers" Aeson..= regFileToJSON registers+          ],+      decode = decodeSnapshotValue+    } -The DSL derives a fold fingerprint from the spec automatically; a hand-written-service has no spec, so its fold identity must be owned by hand. Treat the-token as a change detector, not an encoding version: keep it stable while fold-semantics are stable, and change it in the same edit that changes any guard,-register update, emitted output, or target state, including logic in helper-functions the fold calls. A convention such as @"orders-fold-v3"@ keeps the-token greppable and reviewable. Forgetting to bump it recreates the silent-stale-snapshot hazard this type exists to prevent; see-'defaultStateCodecWithFold'.--}+-- | A hand-owned identity for a hand-written service's event fold.+--+-- The DSL derives a fold fingerprint from the spec automatically; a hand-written+-- service has no spec, so its fold identity must be owned by hand. Treat the+-- token as a change detector, not an encoding version: keep it stable while fold+-- semantics are stable, and change it in the same edit that changes any guard,+-- register update, emitted output, or target state, including logic in helper+-- functions the fold calls. A convention such as @"orders-fold-v3"@ keeps the+-- token greppable and reviewable. Forgetting to bump it recreates the silent+-- stale-snapshot hazard this type exists to prevent; see+-- 'defaultStateCodecWithFold'. newtype FoldVersion = FoldVersion Text-    deriving stock (Eq, Show)--{- | The default snapshot codec for hand-written services: 'defaultStateCodec'-with a hand-owned 'FoldVersion' composed into the control-state discriminator-via 'withFoldFingerprint'.+  deriving stock (Eq, Show) -Prefer this over bare 'defaultStateCodec' whenever the service's fold is-hand-written. A changed token changes the stored discriminator, so an old-snapshot is simply not found and hydration falls back to a full replay of the-event log: a performance cost, never wrong state. The rendered discriminator-stays operator-readable as @<state-shape-hash>;fold=<token>@.--}+-- | The default snapshot codec for hand-written services: 'defaultStateCodec'+-- with a hand-owned 'FoldVersion' composed into the control-state discriminator+-- via 'withFoldFingerprint'.+--+-- Prefer this over bare 'defaultStateCodec' whenever the service's fold is+-- hand-written. A changed token changes the stored discriminator, so an old+-- snapshot is simply not found and hydration falls back to a full replay of the+-- event log: a performance cost, never wrong state. The rendered discriminator+-- stays operator-readable as @<state-shape-hash>;fold=<token>@. defaultStateCodecWithFold ::-    forall rs s.-    (CanonicalStateShape s, FromJSON s, KnownRegFileShape rs, RegFileToJSON rs, ToJSON s) =>-    FoldVersion ->-    Int ->-    StateCodec (s, RegFile rs)+  forall rs s.+  (CanonicalStateShape s, FromJSON s, KnownRegFileShape rs, RegFileToJSON rs, ToJSON s) =>+  FoldVersion ->+  Int ->+  StateCodec (s, RegFile rs) defaultStateCodecWithFold (FoldVersion token) version =-    withFoldFingerprint token (defaultStateCodec version)--{- | Compose a caller-supplied fold identity into the control-state-discriminator.+  withFoldFingerprint token (defaultStateCodec version) -The fingerprint is a change detector, not an encoding version. Keep it stable-when fold semantics are stable and change it whenever guards, updates, targets,-or other event-folding behavior changes. The rendered form remains-operator-readable as @<state-shape-hash>;fold=<fingerprint>@.--}+-- | Compose a caller-supplied fold identity into the control-state+-- discriminator.+--+-- The fingerprint is a change detector, not an encoding version. Keep it stable+-- when fold semantics are stable and change it whenever guards, updates, targets,+-- or other event-folding behavior changes. The rendered form remains+-- operator-readable as @<state-shape-hash>;fold=<fingerprint>@. withFoldFingerprint :: Text -> StateCodec state -> StateCodec state withFoldFingerprint fingerprint codec =-    codec-        { stateShapeHash =-            codec ^. #stateShapeHash <> ";fold=" <> fingerprint-        }+  codec+    { stateShapeHash =+        codec ^. #stateShapeHash <> ";fold=" <> fingerprint+    }  decodeSnapshotValue ::-    forall rs s.-    (FromJSON s, RegFileToJSON rs) =>-    Value ->-    Either Text (s, RegFile rs)+  forall rs s.+  (FromJSON s, RegFileToJSON rs) =>+  Value ->+  Either Text (s, RegFile rs) decodeSnapshotValue value =-    case parseEither parser value of-        Left message -> Left (Text.pack message)-        Right pair -> Right pair+  case parseEither parser value of+    Left message -> Left (Text.pack message)+    Right pair -> Right pair   where     parser = withObject "Keiro snapshot" $ \objectValue -> do-        stateValue <- objectValue .: "state"-        registerValue <- objectValue .: "registers"-        state <- case Aeson.fromJSON stateValue of-            Error message -> fail ("state: " <> message)-            Success decoded -> pure decoded-        registers <- case regFileFromJSON @rs registerValue of-            Left message -> fail ("registers: " <> message)-            Right decoded -> pure decoded-        pure (state, registers)+      stateValue <- objectValue .: "state"+      registerValue <- objectValue .: "registers"+      state <- case Aeson.fromJSON stateValue of+        Error message -> fail ("state: " <> message)+        Success decoded -> pure decoded+      registers <- case regFileFromJSON @rs registerValue of+        Left message -> fail ("registers: " <> message)+        Right decoded -> pure decoded+      pure (state, registers)
src/Keiro/Snapshot/Schema.hs view
@@ -1,33 +1,32 @@-{- | The @keiro_snapshots@ table: persistence for aggregate snapshots.--One row per stream holds the latest snapshot of its folded state as JSONB,-tagged with the 'stateCodecVersion', 'regfileShapeHash', and 'stateShapeHash'-that produced it. 'lookupSnapshot' fetches the newest row matching all three-discriminators (so incompatible snapshots are simply not found). Within one-discriminator tuple, 'writeSnapshotRow' keeps only the highest stream version,-so a late or out-of-order write cannot regress the snapshot.--A write with a /different/ discriminator deliberately replaces the row even-at a lower stream version. This lets a rolled-back deployment-reclaim the single snapshot slot instead of being locked out by a newer codec-forever. During a mixed-version deployment, however, writers with incompatible-codecs can thrash that row and each side will miss the other's snapshot. The-cost is repeated full replay, never incorrect state: the event log remains the-source of truth.--This module is the storage layer beneath "Keiro.Snapshot"; callers normally-go through 'Keiro.Snapshot.hydrateWithSnapshot' and-'Keiro.Snapshot.writeSnapshot' rather than these statements directly.--}-module Keiro.Snapshot.Schema (-    -- * Rows+-- | The @keiro_snapshots@ table: persistence for aggregate snapshots.+--+-- One row per stream holds the latest snapshot of its folded state as JSONB,+-- tagged with the 'stateCodecVersion', 'regfileShapeHash', and 'stateShapeHash'+-- that produced it. 'lookupSnapshot' fetches the newest row matching all three+-- discriminators (so incompatible snapshots are simply not found). Within one+-- discriminator tuple, 'writeSnapshotRow' keeps only the highest stream version,+-- so a late or out-of-order write cannot regress the snapshot.+--+-- A write with a /different/ discriminator deliberately replaces the row even+-- at a lower stream version. This lets a rolled-back deployment+-- reclaim the single snapshot slot instead of being locked out by a newer codec+-- forever. During a mixed-version deployment, however, writers with incompatible+-- codecs can thrash that row and each side will miss the other's snapshot. The+-- cost is repeated full replay, never incorrect state: the event log remains the+-- source of truth.+--+-- This module is the storage layer beneath "Keiro.Snapshot"; callers normally+-- go through 'Keiro.Snapshot.hydrateWithSnapshot' and+-- 'Keiro.Snapshot.writeSnapshot' rather than these statements directly.+module Keiro.Snapshot.Schema+  ( -- * Rows     SnapshotRow (..),     SnapshotWrite (..),      -- * Storage     lookupSnapshot,     writeSnapshotRow,-)+  ) where  import Contravariant.Extras (contrazip4, contrazip6)@@ -42,129 +41,125 @@ import "hasql-transaction" Hasql.Transaction qualified as Tx import Prelude qualified -{- | A snapshot row as read back from @keiro_snapshots@: the stored 'state'-JSON, the 'streamVersion' it captures, the 'stateCodecVersion' and-'regfileShapeHash' and 'stateShapeHash' that gate compatibility, and the create/update-timestamps.--}+-- | A snapshot row as read back from @keiro_snapshots@: the stored 'state'+-- JSON, the 'streamVersion' it captures, the 'stateCodecVersion' and+-- 'regfileShapeHash' and 'stateShapeHash' that gate compatibility, and the create/update+-- timestamps. data SnapshotRow = SnapshotRow-    { streamId :: !StreamId-    , streamVersion :: !StreamVersion-    , state :: !Value-    , stateCodecVersion :: !Int-    , regfileShapeHash :: !Text-    , stateShapeHash :: !Text-    , createdAt :: !UTCTime-    , updatedAt :: !UTCTime-    }-    deriving stock (Generic, Eq, Show)+  { streamId :: !StreamId,+    streamVersion :: !StreamVersion,+    state :: !Value,+    stateCodecVersion :: !Int,+    regfileShapeHash :: !Text,+    stateShapeHash :: !Text,+    createdAt :: !UTCTime,+    updatedAt :: !UTCTime+  }+  deriving stock (Generic, Eq, Show) -{- | The fields needed to write a snapshot — 'SnapshotRow' minus the-database-managed timestamps.--}+-- | The fields needed to write a snapshot — 'SnapshotRow' minus the+-- database-managed timestamps. data SnapshotWrite = SnapshotWrite-    { streamId :: !StreamId-    , streamVersion :: !StreamVersion-    , state :: !Value-    , stateCodecVersion :: !Int-    , regfileShapeHash :: !Text-    , stateShapeHash :: !Text-    }-    deriving stock (Generic, Eq, Show)+  { streamId :: !StreamId,+    streamVersion :: !StreamVersion,+    state :: !Value,+    stateCodecVersion :: !Int,+    regfileShapeHash :: !Text,+    stateShapeHash :: !Text+  }+  deriving stock (Generic, Eq, Show) -{- | Fetch the latest snapshot for a stream that matches all three codec-discriminators. Returns 'Nothing' when no compatible snapshot exists, so an-incompatible one is treated as absent.--}+-- | Fetch the latest snapshot for a stream that matches all three codec+-- discriminators. Returns 'Nothing' when no compatible snapshot exists, so an+-- incompatible one is treated as absent. lookupSnapshot ::-    (Store :> es) =>-    StreamId ->-    Int ->-    Text ->-    Text ->-    Eff es (Maybe SnapshotRow)+  (Store :> es) =>+  StreamId ->+  Int ->+  Text ->+  Text ->+  Eff es (Maybe SnapshotRow) lookupSnapshot streamId version shapeHash stateShapeHash =-    runTransaction-        $ Tx.statement-            (streamIdToInt streamId, Prelude.fromIntegral version, shapeHash, stateShapeHash)-            lookupSnapshotStmt+  runTransaction+    $ Tx.statement+      (streamIdToInt streamId, Prelude.fromIntegral version, shapeHash, stateShapeHash)+      lookupSnapshotStmt -{- | Upsert a snapshot row for its stream. For the same discriminator tuple,-the write only takes effect when its 'streamVersion' is at least the stored-one. Any incompatible discriminator replaces the row even at a lower version-so codec rollback can make progress; see the module header for the-mixed-deployment performance caveat.--}+-- | Upsert a snapshot row for its stream. For the same discriminator tuple,+-- the write only takes effect when its 'streamVersion' is at least the stored+-- one. Any incompatible discriminator replaces the row even at a lower version+-- so codec rollback can make progress; see the module header for the+-- mixed-deployment performance caveat. writeSnapshotRow ::-    (Store :> es) =>-    SnapshotWrite ->-    Eff es ()+  (Store :> es) =>+  SnapshotWrite ->+  Eff es () writeSnapshotRow snapshot =-    runTransaction-        $ Tx.statement (snapshotWriteParams snapshot) writeSnapshotStmt+  runTransaction+    $ Tx.statement (snapshotWriteParams snapshot) writeSnapshotStmt  lookupSnapshotStmt :: Statement (Int64, Int64, Text, Text) (Maybe SnapshotRow) lookupSnapshotStmt =-    preparable-        """-        SELECT stream_id, stream_version, state, state_codec_version, regfile_shape_hash, state_shape_hash, created_at, updated_at-        FROM keiro.keiro_snapshots-        WHERE stream_id = $1-          AND state_codec_version = $2-          AND regfile_shape_hash = $3-          AND state_shape_hash = $4-        ORDER BY stream_version DESC-        LIMIT 1-        """-        ( contrazip4-            (E.param (E.nonNullable E.int8))-            (E.param (E.nonNullable E.int8))-            (E.param (E.nonNullable E.text))-            (E.param (E.nonNullable E.text))-        )-        (D.rowMaybe snapshotRowDecoder)+  preparable+    """+    SELECT stream_id, stream_version, state, state_codec_version, regfile_shape_hash, state_shape_hash, created_at, updated_at+    FROM keiro.keiro_snapshots+    WHERE stream_id = $1+      AND state_codec_version = $2+      AND regfile_shape_hash = $3+      AND state_shape_hash = $4+    ORDER BY stream_version DESC+    LIMIT 1+    """+    ( contrazip4+        (E.param (E.nonNullable E.int8))+        (E.param (E.nonNullable E.int8))+        (E.param (E.nonNullable E.text))+        (E.param (E.nonNullable E.text))+    )+    (D.rowMaybe snapshotRowDecoder)  writeSnapshotStmt :: Statement (Int64, Int64, Value, Int64, Text, Text) () writeSnapshotStmt =-    preparable-        """-        INSERT INTO keiro.keiro_snapshots-          (stream_id, stream_version, state, state_codec_version, regfile_shape_hash, state_shape_hash)-        VALUES-          ($1, $2, $3, $4, $5, $6)-        ON CONFLICT (stream_id) DO UPDATE-          SET stream_version = EXCLUDED.stream_version,-              state = EXCLUDED.state,-              state_codec_version = EXCLUDED.state_codec_version,-              regfile_shape_hash = EXCLUDED.regfile_shape_hash,-              state_shape_hash = EXCLUDED.state_shape_hash,-              updated_at = now()-          WHERE keiro_snapshots.stream_version <= EXCLUDED.stream_version-             OR keiro_snapshots.state_codec_version <> EXCLUDED.state_codec_version-             OR keiro_snapshots.regfile_shape_hash <> EXCLUDED.regfile_shape_hash-             OR keiro_snapshots.state_shape_hash <> EXCLUDED.state_shape_hash-        """-        ( contrazip6-            (E.param (E.nonNullable E.int8))-            (E.param (E.nonNullable E.int8))-            (E.param (E.nonNullable E.jsonb))-            (E.param (E.nonNullable E.int8))-            (E.param (E.nonNullable E.text))-            (E.param (E.nonNullable E.text))-        )-        D.noResult+  preparable+    """+    INSERT INTO keiro.keiro_snapshots+      (stream_id, stream_version, state, state_codec_version, regfile_shape_hash, state_shape_hash)+    VALUES+      ($1, $2, $3, $4, $5, $6)+    ON CONFLICT (stream_id) DO UPDATE+      SET stream_version = EXCLUDED.stream_version,+          state = EXCLUDED.state,+          state_codec_version = EXCLUDED.state_codec_version,+          regfile_shape_hash = EXCLUDED.regfile_shape_hash,+          state_shape_hash = EXCLUDED.state_shape_hash,+          updated_at = now()+      WHERE keiro_snapshots.stream_version <= EXCLUDED.stream_version+         OR keiro_snapshots.state_codec_version <> EXCLUDED.state_codec_version+         OR keiro_snapshots.regfile_shape_hash <> EXCLUDED.regfile_shape_hash+         OR keiro_snapshots.state_shape_hash <> EXCLUDED.state_shape_hash+    """+    ( contrazip6+        (E.param (E.nonNullable E.int8))+        (E.param (E.nonNullable E.int8))+        (E.param (E.nonNullable E.jsonb))+        (E.param (E.nonNullable E.int8))+        (E.param (E.nonNullable E.text))+        (E.param (E.nonNullable E.text))+    )+    D.noResult  snapshotRowDecoder :: D.Row SnapshotRow snapshotRowDecoder =-    SnapshotRow-        <$> (StreamId <$> D.column (D.nonNullable D.int8))-        <*> (StreamVersion <$> D.column (D.nonNullable D.int8))-        <*> D.column (D.nonNullable D.jsonb)-        <*> (Prelude.fromIntegral <$> D.column (D.nonNullable D.int8))-        <*> D.column (D.nonNullable D.text)-        <*> D.column (D.nonNullable D.text)-        <*> D.column (D.nonNullable D.timestamptz)-        <*> D.column (D.nonNullable D.timestamptz)+  SnapshotRow+    <$> (StreamId <$> D.column (D.nonNullable D.int8))+    <*> (StreamVersion <$> D.column (D.nonNullable D.int8))+    <*> D.column (D.nonNullable D.jsonb)+    <*> (Prelude.fromIntegral <$> D.column (D.nonNullable D.int8))+    <*> D.column (D.nonNullable D.text)+    <*> D.column (D.nonNullable D.text)+    <*> D.column (D.nonNullable D.timestamptz)+    <*> D.column (D.nonNullable D.timestamptz)  streamIdToInt :: StreamId -> Int64 streamIdToInt (StreamId value) = value@@ -174,10 +169,10 @@  snapshotWriteParams :: SnapshotWrite -> (Int64, Int64, Value, Int64, Text, Text) snapshotWriteParams snapshot =-    ( streamIdToInt (snapshot ^. #streamId)-    , streamVersionToInt (snapshot ^. #streamVersion)-    , snapshot ^. #state-    , Prelude.fromIntegral (snapshot ^. #stateCodecVersion)-    , snapshot ^. #regfileShapeHash-    , snapshot ^. #stateShapeHash-    )+  ( streamIdToInt (snapshot ^. #streamId),+    streamVersionToInt (snapshot ^. #streamVersion),+    snapshot ^. #state,+    Prelude.fromIntegral (snapshot ^. #stateCodecVersion),+    snapshot ^. #regfileShapeHash,+    snapshot ^. #stateShapeHash+  )
src/Keiro/Subscription/Shard.hs view
@@ -1,36 +1,35 @@-{- | Cooperative consumer-group ownership for category subscriptions (EP-51).--kiroku already partitions a category into @N@ buckets (consumer-group members) by-a stable hash of the originating stream id, and keeps a per-member checkpoint, so-@N@ disjoint readers can drain a busy category in parallel. What kiroku leaves to-the operator is /membership/: "exactly one live process must own each member-index at a time" is, by itself, a manual @[0..N-1]@ wiring. This module supplies-the missing operability layer — a __lease__ over each bucket so a pool of-identical worker processes agree, with no external coordinator, on who owns which-bucket right now and re-divide the buckets automatically when a worker joins,-leaves, or dies.--The storage and SQL live in "Keiro.Subscription.Shard.Schema"; this module is the-typed 'Eff'-level surface over kiroku's 'Store':--* 'freshWorkerId' mints the per-process owner id.-* 'acquireOwnedBuckets' is the one-pass reconcile: renew the leases this worker-  still holds, then claim up to a /fair share/ more (taking over any expired-  leases), returning the buckets owned after the pass.-* 'renewOwnedBuckets' / 'relinquish' are the heartbeat and the graceful release.-* 'ensureShards' / 'ownershipSnapshot' populate and read the table.--The lease, not a held lock, is the ownership mechanism: a transaction-scoped-advisory lock auto-releases at transaction end (so it cannot span a worker's-multi-transaction lifetime) and a session-scoped lock has no connection affinity-through kiroku's pooled 'Store' — the same finding-'Keiro.Workflow.Resume.WorkflowResumeOptions' records for the resume worker. A-renewable @lease_expires_at@ timestamp gives lifetime ownership and automatic-failover without depending on connection affinity, and disjointness rests on the-@FOR UPDATE SKIP LOCKED@ claim, not on the liveness estimate being exact.--}-module Keiro.Subscription.Shard (-    -- * Worker identity+-- | Cooperative consumer-group ownership for category subscriptions (EP-51).+--+-- kiroku already partitions a category into @N@ buckets (consumer-group members) by+-- a stable hash of the originating stream id, and keeps a per-member checkpoint, so+-- @N@ disjoint readers can drain a busy category in parallel. What kiroku leaves to+-- the operator is /membership/: "exactly one live process must own each member+-- index at a time" is, by itself, a manual @[0..N-1]@ wiring. This module supplies+-- the missing operability layer — a __lease__ over each bucket so a pool of+-- identical worker processes agree, with no external coordinator, on who owns which+-- bucket right now and re-divide the buckets automatically when a worker joins,+-- leaves, or dies.+--+-- The storage and SQL live in "Keiro.Subscription.Shard.Schema"; this module is the+-- typed 'Eff'-level surface over kiroku's 'Store':+--+-- * 'freshWorkerId' mints the per-process owner id.+-- * 'acquireOwnedBuckets' is the one-pass reconcile: renew the leases this worker+--   still holds, then claim up to a /fair share/ more (taking over any expired+--   leases), returning the buckets owned after the pass.+-- * 'renewOwnedBuckets' / 'relinquish' are the heartbeat and the graceful release.+-- * 'ensureShards' / 'ownershipSnapshot' populate and read the table.+--+-- The lease, not a held lock, is the ownership mechanism: a transaction-scoped+-- advisory lock auto-releases at transaction end (so it cannot span a worker's+-- multi-transaction lifetime) and a session-scoped lock has no connection affinity+-- through kiroku's pooled 'Store' — the same finding+-- 'Keiro.Workflow.Resume.WorkflowResumeOptions' records for the resume worker. A+-- renewable @lease_expires_at@ timestamp gives lifetime ownership and automatic+-- failover without depending on connection affinity, and disjointness rests on the+-- @FOR UPDATE SKIP LOCKED@ claim, not on the liveness estimate being exact.+module Keiro.Subscription.Shard+  ( -- * Worker identity     WorkerId (..),     freshWorkerId, @@ -47,7 +46,7 @@      -- * Fair-share helper     fairShareTarget,-)+  ) where  import Data.Set (Set)@@ -57,15 +56,15 @@ import Effectful (Eff, IOE, (:>)) import Effectful.Exception (Exception, throwIO) import Keiro.Prelude-import Keiro.Subscription.Shard.Schema (-    WorkerId (..),+import Keiro.Subscription.Shard.Schema+  ( WorkerId (..),     claimShardsTx,     ensureShardRows,     listShardCounts,     listShardOwnership,     releaseShardsTx,     renewLeaseTx,- )+  ) import Kiroku.Store.Effect (Store) import Kiroku.Store.Subscription.Types (SubscriptionName (..)) import Kiroku.Store.Transaction (runTransaction)@@ -74,111 +73,104 @@ freshWorkerId :: (IOE :> es) => Eff es WorkerId freshWorkerId = WorkerId <$> liftIO UUIDv4.nextRandom -{- | Everything an ownership pass needs for one @(subscription, worker)@: which-subscription is being sharded, this worker's id, the fixed bucket count @N@, and-how long a claim/renew is valid before it expires.--}+-- | Everything an ownership pass needs for one @(subscription, worker)@: which+-- subscription is being sharded, this worker's id, the fixed bucket count @N@, and+-- how long a claim/renew is valid before it expires. data ShardLease = ShardLease-    { subscriptionName :: !SubscriptionName-    , workerId :: !WorkerId-    , shardCount :: !Int-    -- ^ @N@; the fixed number of buckets for this subscription name.-    , leaseTtl :: !NominalDiffTime-    -- ^ How long a claim or renewal keeps a bucket before it expires.-    }-    deriving stock (Generic)+  { subscriptionName :: !SubscriptionName,+    workerId :: !WorkerId,+    -- | @N@; the fixed number of buckets for this subscription name.+    shardCount :: !Int,+    -- | How long a claim or renewal keeps a bucket before it expires.+    leaseTtl :: !NominalDiffTime+  }+  deriving stock (Generic)  data ShardCountMismatch = ShardCountMismatch-    { mismatchSubscriptionName :: !Text-    , mismatchConfigured :: !Int-    , mismatchFound :: ![Int]-    }-    deriving stock (Generic, Eq, Show)-    deriving anyclass (Exception)+  { mismatchSubscriptionName :: !Text,+    mismatchConfigured :: !Int,+    mismatchFound :: ![Int]+  }+  deriving stock (Generic, Eq, Show)+  deriving anyclass (Exception) -{- | The fair-share claim target: @ceil(N / liveWorkers)@. When @k@ workers are-live they collectively claim all @N@ buckets and no single worker hogs them. A-non-positive @liveWorkers@ is treated as one (claim everything).--}+-- | The fair-share claim target: @ceil(N / liveWorkers)@. When @k@ workers are+-- live they collectively claim all @N@ buckets and no single worker hogs them. A+-- non-positive @liveWorkers@ is treated as one (claim everything). fairShareTarget :: Int -> Int -> Int fairShareTarget shardCount liveWorkers =-    let k = max 1 liveWorkers-     in (shardCount + k - 1) `div` k+  let k = max 1 liveWorkers+   in (shardCount + k - 1) `div` k -{- | Idempotently populate the @N@ shard rows for this subscription. Safe to call-on every worker startup ('ensureShardRows' uses @ON CONFLICT DO NOTHING@).--}+-- | Idempotently populate the @N@ shard rows for this subscription. Safe to call+-- on every worker startup ('ensureShardRows' uses @ON CONFLICT DO NOTHING@). ensureShards :: (Store :> es) => ShardLease -> Eff es () ensureShards lease = do-    counts <- runTransaction $ do-        ensureShardRows (subscriptionName lease) (shardCount lease)-        listShardCounts (subscriptionName lease)-    let configured = shardCount lease-        found = [n | (n, _) <- counts, n /= configured]-    unless (null found) $-        throwIO-            ShardCountMismatch-                { mismatchSubscriptionName = case subscriptionName lease of-                    SubscriptionName name -> name-                , mismatchConfigured = configured-                , mismatchFound = found-                }--{- | One ownership-reconcile pass: in a single transaction, renew the leases this-worker still holds, then — if it holds fewer than its fair share — claim __one__-more bucket (unowned or expired). Returns the set of buckets owned __after__ the-pass.--Claiming __one at a time__ is deliberate and is what makes a pool of identical-workers converge to a fair split without any external coordinator. If a cold-worker grabbed its whole fair share at once it could, racing alone before its-peers' first pass, monopolise every bucket and then never see the idle peers-(they own nothing, so they are invisible in the lease table). Taking one bucket-per pass instead means concurrently-starting workers each grab one, become-visible after the first pass, and climb to an even share together; a worker-joining a balanced pool only picks up buckets freed by an expired lease-(failover). Ownership spreads over up to @N@ reconcile intervals — a deliberate-trade of spin-up latency for coordinator-free fairness.+  counts <- runTransaction $ do+    ensureShardRows (subscriptionName lease) (shardCount lease)+    listShardCounts (subscriptionName lease)+  let configured = shardCount lease+      found = [n | (n, _) <- counts, n /= configured]+  unless (null found) $+    throwIO+      ShardCountMismatch+        { mismatchSubscriptionName = case subscriptionName lease of+            SubscriptionName name -> name,+          mismatchConfigured = configured,+          mismatchFound = found+        } -@liveWorkers@ is the caller's estimate of how many workers are currently live-(see 'ownershipSnapshot'); it tunes the fair-share target and self-corrects next-pass. It never causes double ownership, because the @FOR UPDATE SKIP LOCKED@-claim is the real exclusion mechanism.--}+-- | One ownership-reconcile pass: in a single transaction, renew the leases this+-- worker still holds, then — if it holds fewer than its fair share — claim __one__+-- more bucket (unowned or expired). Returns the set of buckets owned __after__ the+-- pass.+--+-- Claiming __one at a time__ is deliberate and is what makes a pool of identical+-- workers converge to a fair split without any external coordinator. If a cold+-- worker grabbed its whole fair share at once it could, racing alone before its+-- peers' first pass, monopolise every bucket and then never see the idle peers+-- (they own nothing, so they are invisible in the lease table). Taking one bucket+-- per pass instead means concurrently-starting workers each grab one, become+-- visible after the first pass, and climb to an even share together; a worker+-- joining a balanced pool only picks up buckets freed by an expired lease+-- (failover). Ownership spreads over up to @N@ reconcile intervals — a deliberate+-- trade of spin-up latency for coordinator-free fairness.+--+-- @liveWorkers@ is the caller's estimate of how many workers are currently live+-- (see 'ownershipSnapshot'); it tunes the fair-share target and self-corrects next+-- pass. It never causes double ownership, because the @FOR UPDATE SKIP LOCKED@+-- claim is the real exclusion mechanism. acquireOwnedBuckets :: (IOE :> es, Store :> es) => ShardLease -> Int -> Eff es (Set Int) acquireOwnedBuckets lease liveWorkers = do-    now <- liftIO getCurrentTime-    let target = fairShareTarget (shardCount lease) liveWorkers-    runTransaction $ do-        held <- renewLeaseTx (subscriptionName lease) (workerId lease) now (leaseTtl lease)-        -- Claim at most one bucket per pass (see the note above on convergence).-        claimed <--            if length held < target-                then claimShardsTx (subscriptionName lease) (workerId lease) 1 now (leaseTtl lease)-                else pure []-        pure (Set.fromList held <> Set.fromList claimed)+  now <- liftIO getCurrentTime+  let target = fairShareTarget (shardCount lease) liveWorkers+  runTransaction $ do+    held <- renewLeaseTx (subscriptionName lease) (workerId lease) now (leaseTtl lease)+    -- Claim at most one bucket per pass (see the note above on convergence).+    claimed <-+      if length held < target+        then claimShardsTx (subscriptionName lease) (workerId lease) 1 now (leaseTtl lease)+        else pure []+    pure (Set.fromList held <> Set.fromList claimed) -{- | Renew only — write a fresh expiry for every bucket this worker still holds-and return them. Used when a worker wants to heartbeat without claiming more.--}+-- | Renew only — write a fresh expiry for every bucket this worker still holds+-- and return them. Used when a worker wants to heartbeat without claiming more. renewOwnedBuckets :: (IOE :> es, Store :> es) => ShardLease -> Eff es (Set Int) renewOwnedBuckets lease = do-    now <- liftIO getCurrentTime-    held <- runTransaction (renewLeaseTx (subscriptionName lease) (workerId lease) now (leaseTtl lease))-    pure (Set.fromList held)+  now <- liftIO getCurrentTime+  held <- runTransaction (renewLeaseTx (subscriptionName lease) (workerId lease) now (leaseTtl lease))+  pure (Set.fromList held) -{- | Graceful release of the given buckets (clean shutdown), so they are-claimable immediately instead of after lease expiry.--}+-- | Graceful release of the given buckets (clean shutdown), so they are+-- claimable immediately instead of after lease expiry. relinquish :: (Store :> es) => ShardLease -> Set Int -> Eff es () relinquish lease buckets =-    runTransaction (releaseShardsTx (subscriptionName lease) (workerId lease) (Set.toList buckets))+  runTransaction (releaseShardsTx (subscriptionName lease) (workerId lease) (Set.toList buckets)) -{- | Read every bucket's @(bucket, owner, lease_expires_at)@ for this-subscription. The worker uses it to estimate @liveWorkers@ (count of distinct-non-expired owners) before an 'acquireOwnedBuckets' pass.--}+-- | Read every bucket's @(bucket, owner, lease_expires_at)@ for this+-- subscription. The worker uses it to estimate @liveWorkers@ (count of distinct+-- non-expired owners) before an 'acquireOwnedBuckets' pass. ownershipSnapshot ::-    (Store :> es) => ShardLease -> Eff es [(Int, Maybe WorkerId, Maybe UTCTime)]+  (Store :> es) => ShardLease -> Eff es [(Int, Maybe WorkerId, Maybe UTCTime)] ownershipSnapshot lease =-    runTransaction (listShardOwnership (subscriptionName lease))+  runTransaction (listShardOwnership (subscriptionName lease))
src/Keiro/Subscription/Shard/Schema.hs view
@@ -1,28 +1,27 @@-{- | The @keiro_subscription_shards@ table: storage and lease logic for-cooperative consumer-group ownership (EP-51).--A category subscription can be split across @N@ buckets — kiroku consumer-group-member indices in @[0, N)@ — so that @N@ cooperating workers each drain a-disjoint slice of the keyspace. This module owns the durable __assignment__-layer: one row per @(subscription_name, bucket)@ recording which worker holds it-right now, as a renewable __lease__ (an owner id plus an expiry timestamp). A-live worker renews its lease on a heartbeat; a dead worker stops renewing, its-lease expires, and another worker re-claims the bucket (failover). It does-__not__ store event positions — kiroku's per-member checkpoints-(@(subscription_name, consumer_group_member)@) do that, so a re-homed bucket-resumes where its previous owner left off.--The statements here are 'Hasql.Transaction.Transaction'-flavoured so callers can-compose several into one short transaction (e.g. renew-then-claim in-'Keiro.Subscription.Shard.acquireOwnedBuckets'); the typed 'Eff'-level wrappers-that run them through kiroku's pool live in "Keiro.Subscription.Shard". The-claim uses @FOR UPDATE SKIP LOCKED@ over the claimable rows, exactly as-'Keiro.Timer.Schema.claimDueTimer' does, so two workers racing the same bucket-can never both win — a stale "how many workers are live" estimate only changes-how aggressively a worker claims, never whether ownership stays disjoint.--}-module Keiro.Subscription.Shard.Schema (-    -- * Worker identity+-- | The @keiro_subscription_shards@ table: storage and lease logic for+-- cooperative consumer-group ownership (EP-51).+--+-- A category subscription can be split across @N@ buckets — kiroku consumer-group+-- member indices in @[0, N)@ — so that @N@ cooperating workers each drain a+-- disjoint slice of the keyspace. This module owns the durable __assignment__+-- layer: one row per @(subscription_name, bucket)@ recording which worker holds it+-- right now, as a renewable __lease__ (an owner id plus an expiry timestamp). A+-- live worker renews its lease on a heartbeat; a dead worker stops renewing, its+-- lease expires, and another worker re-claims the bucket (failover). It does+-- __not__ store event positions — kiroku's per-member checkpoints+-- (@(subscription_name, consumer_group_member)@) do that, so a re-homed bucket+-- resumes where its previous owner left off.+--+-- The statements here are 'Hasql.Transaction.Transaction'-flavoured so callers can+-- compose several into one short transaction (e.g. renew-then-claim in+-- 'Keiro.Subscription.Shard.acquireOwnedBuckets'); the typed 'Eff'-level wrappers+-- that run them through kiroku's pool live in "Keiro.Subscription.Shard". The+-- claim uses @FOR UPDATE SKIP LOCKED@ over the claimable rows, exactly as+-- 'Keiro.Timer.Schema.claimDueTimer' does, so two workers racing the same bucket+-- can never both win — a stale "how many workers are live" estimate only changes+-- how aggressively a worker claims, never whether ownership stays disjoint.+module Keiro.Subscription.Shard.Schema+  ( -- * Worker identity     WorkerId (..),      -- * Lease statements (composable within a transaction)@@ -32,7 +31,7 @@     releaseShardsTx,     listShardOwnership,     listShardCounts,-)+  ) where  import Contravariant.Extras (contrazip2, contrazip3, contrazip4, contrazip5)@@ -46,182 +45,176 @@ import Kiroku.Store.Subscription.Types (SubscriptionName (..)) import "hasql-transaction" Hasql.Transaction qualified as Tx -{- | A per-process unique id naming the owner in a lease row. A UUID minted once-at worker start ('Keiro.Subscription.Shard.freshWorkerId'); two restarts of the-same binary get two different ids, so a restarted process never inherits the-dead process's leases — it claims afresh once the old leases expire.--}+-- | A per-process unique id naming the owner in a lease row. A UUID minted once+-- at worker start ('Keiro.Subscription.Shard.freshWorkerId'); two restarts of the+-- same binary get two different ids, so a restarted process never inherits the+-- dead process's leases — it claims afresh once the old leases expire. newtype WorkerId = WorkerId UUID-    deriving stock (Eq, Ord, Show)+  deriving stock (Eq, Ord, Show) -{- | Idempotently insert the @N@ rows @(name, bucket = 0..N-1, shard_count = N)@-with @owner_worker_id@ left @NULL@. @ON CONFLICT DO NOTHING@ makes calling it-on every worker startup safe; it converges the table to exactly @N@ rows.--}+-- | Idempotently insert the @N@ rows @(name, bucket = 0..N-1, shard_count = N)@+-- with @owner_worker_id@ left @NULL@. @ON CONFLICT DO NOTHING@ makes calling it+-- on every worker startup safe; it converges the table to exactly @N@ rows. ensureShardRows :: SubscriptionName -> Int -> Tx.Transaction () ensureShardRows (SubscriptionName name) shardCount =-    Tx.statement (name, fromIntegral shardCount) ensureShardRowsStmt+  Tx.statement (name, fromIntegral shardCount) ensureShardRowsStmt -{- | Claim up to @targetCount@ buckets that are currently unowned __or__ whose-lease has expired (@owner_worker_id IS NULL OR lease_expires_at < now@), in one-statement, returning the bucket numbers actually claimed. @FOR UPDATE SKIP-LOCKED@ over the claimable rows is the exclusion mechanism: two workers racing-the same bucket cannot both win. The TTL is added to @now@ here (in Haskell) to-form the new @lease_expires_at@.--}+-- | Claim up to @targetCount@ buckets that are currently unowned __or__ whose+-- lease has expired (@owner_worker_id IS NULL OR lease_expires_at < now@), in one+-- statement, returning the bucket numbers actually claimed. @FOR UPDATE SKIP+-- LOCKED@ over the claimable rows is the exclusion mechanism: two workers racing+-- the same bucket cannot both win. The TTL is added to @now@ here (in Haskell) to+-- form the new @lease_expires_at@. claimShardsTx ::-    SubscriptionName -> WorkerId -> Int -> UTCTime -> NominalDiffTime -> Tx.Transaction [Int]+  SubscriptionName -> WorkerId -> Int -> UTCTime -> NominalDiffTime -> Tx.Transaction [Int] claimShardsTx (SubscriptionName name) (WorkerId worker) targetCount now ttl =-    fmap (fmap fromIntegral) $-        Tx.statement-            (name, now, addUTCTime ttl now, worker, fromIntegral targetCount)-            claimShardsStmt+  fmap (fmap fromIntegral) $+    Tx.statement+      (name, now, addUTCTime ttl now, worker, fromIntegral targetCount)+      claimShardsStmt -{- | Renew every lease this worker still holds: write a fresh @lease_expires_at =-now + ttl@ and @heartbeat_at = now@ for each row it owns, returning the buckets-still held. A bucket stolen after this worker's lease lapsed is owned by someone-else and so is __not__ in the result — that is how a worker learns it lost a-bucket and stops reading it.--}+-- | Renew every lease this worker still holds: write a fresh @lease_expires_at =+-- now + ttl@ and @heartbeat_at = now@ for each row it owns, returning the buckets+-- still held. A bucket stolen after this worker's lease lapsed is owned by someone+-- else and so is __not__ in the result — that is how a worker learns it lost a+-- bucket and stops reading it. renewLeaseTx :: SubscriptionName -> WorkerId -> UTCTime -> NominalDiffTime -> Tx.Transaction [Int] renewLeaseTx (SubscriptionName name) (WorkerId worker) now ttl =-    fmap (fmap fromIntegral) $-        Tx.statement (name, now, addUTCTime ttl now, worker) renewLeaseStmt+  fmap (fmap fromIntegral) $+    Tx.statement (name, now, addUTCTime ttl now, worker) renewLeaseStmt -{- | Graceful relinquish: clear ownership of the given buckets this worker holds-so they become claimable immediately, without waiting for lease expiry. Called-on clean shutdown. Only rows still owned by @worker@ are affected, so a bucket-already stolen is left untouched.--}+-- | Graceful relinquish: clear ownership of the given buckets this worker holds+-- so they become claimable immediately, without waiting for lease expiry. Called+-- on clean shutdown. Only rows still owned by @worker@ are affected, so a bucket+-- already stolen is left untouched. releaseShardsTx :: SubscriptionName -> WorkerId -> [Int] -> Tx.Transaction () releaseShardsTx (SubscriptionName name) (WorkerId worker) buckets =-    Tx.statement (name, worker, fmap fromIntegral buckets) releaseShardsStmt+  Tx.statement (name, worker, fmap fromIntegral buckets) releaseShardsStmt -{- | Observability/test read of @(bucket, owner, lease_expires_at)@ for one-subscription, ordered by bucket.--}+-- | Observability/test read of @(bucket, owner, lease_expires_at)@ for one+-- subscription, ordered by bucket. listShardOwnership :: SubscriptionName -> Tx.Transaction [(Int, Maybe WorkerId, Maybe UTCTime)] listShardOwnership (SubscriptionName name) =-    Tx.statement name listShardOwnershipStmt+  Tx.statement name listShardOwnershipStmt  -- | Read existing shard-count groups for a subscription as @(shard_count, rows)@. listShardCounts :: SubscriptionName -> Tx.Transaction [(Int, Int)] listShardCounts (SubscriptionName name) =-    Tx.statement name listShardCountsStmt+  Tx.statement name listShardCountsStmt  ensureShardRowsStmt :: Statement (Text, Int32) () ensureShardRowsStmt =-    preparable-        """-        INSERT INTO keiro.keiro_subscription_shards (subscription_name, bucket, shard_count)-        SELECT $1, g, $2-        FROM generate_series(0, $2 - 1) AS g-        ON CONFLICT (subscription_name, bucket) DO NOTHING-        """-        ( contrazip2-            (E.param (E.nonNullable E.text))-            (E.param (E.nonNullable E.int4))-        )-        D.noResult+  preparable+    """+    INSERT INTO keiro.keiro_subscription_shards (subscription_name, bucket, shard_count)+    SELECT $1, g, $2+    FROM generate_series(0, $2 - 1) AS g+    ON CONFLICT (subscription_name, bucket) DO NOTHING+    """+    ( contrazip2+        (E.param (E.nonNullable E.text))+        (E.param (E.nonNullable E.int4))+    )+    D.noResult  claimShardsStmt :: Statement (Text, UTCTime, UTCTime, UUID, Int32) [Int32] claimShardsStmt =-    preparable-        """-        WITH claimable AS (-          SELECT bucket-          FROM keiro.keiro_subscription_shards-          WHERE subscription_name = $1-            AND (owner_worker_id IS NULL OR lease_expires_at < $2)-          ORDER BY bucket-          LIMIT $5-          FOR UPDATE SKIP LOCKED-        )-        UPDATE keiro.keiro_subscription_shards s-        SET owner_worker_id = $4,-            lease_expires_at = $3,-            heartbeat_at = $2,-            updated_at = $2-        FROM claimable c-        WHERE s.subscription_name = $1 AND s.bucket = c.bucket-        RETURNING s.bucket-        """-        ( contrazip5-            (E.param (E.nonNullable E.text))-            (E.param (E.nonNullable E.timestamptz))-            (E.param (E.nonNullable E.timestamptz))-            (E.param (E.nonNullable E.uuid))-            (E.param (E.nonNullable E.int4))-        )-        (D.rowList (D.column (D.nonNullable D.int4)))+  preparable+    """+    WITH claimable AS (+      SELECT bucket+      FROM keiro.keiro_subscription_shards+      WHERE subscription_name = $1+        AND (owner_worker_id IS NULL OR lease_expires_at < $2)+      ORDER BY bucket+      LIMIT $5+      FOR UPDATE SKIP LOCKED+    )+    UPDATE keiro.keiro_subscription_shards s+    SET owner_worker_id = $4,+        lease_expires_at = $3,+        heartbeat_at = $2,+        updated_at = $2+    FROM claimable c+    WHERE s.subscription_name = $1 AND s.bucket = c.bucket+    RETURNING s.bucket+    """+    ( contrazip5+        (E.param (E.nonNullable E.text))+        (E.param (E.nonNullable E.timestamptz))+        (E.param (E.nonNullable E.timestamptz))+        (E.param (E.nonNullable E.uuid))+        (E.param (E.nonNullable E.int4))+    )+    (D.rowList (D.column (D.nonNullable D.int4)))  renewLeaseStmt :: Statement (Text, UTCTime, UTCTime, UUID) [Int32] renewLeaseStmt =-    preparable-        """-        UPDATE keiro.keiro_subscription_shards-        SET lease_expires_at = $3,-            heartbeat_at = $2,-            updated_at = $2-        WHERE subscription_name = $1-          AND owner_worker_id = $4-        RETURNING bucket-        """-        ( contrazip4-            (E.param (E.nonNullable E.text))-            (E.param (E.nonNullable E.timestamptz))-            (E.param (E.nonNullable E.timestamptz))-            (E.param (E.nonNullable E.uuid))-        )-        (D.rowList (D.column (D.nonNullable D.int4)))+  preparable+    """+    UPDATE keiro.keiro_subscription_shards+    SET lease_expires_at = $3,+        heartbeat_at = $2,+        updated_at = $2+    WHERE subscription_name = $1+      AND owner_worker_id = $4+    RETURNING bucket+    """+    ( contrazip4+        (E.param (E.nonNullable E.text))+        (E.param (E.nonNullable E.timestamptz))+        (E.param (E.nonNullable E.timestamptz))+        (E.param (E.nonNullable E.uuid))+    )+    (D.rowList (D.column (D.nonNullable D.int4)))  releaseShardsStmt :: Statement (Text, UUID, [Int32]) () releaseShardsStmt =-    preparable-        """-        UPDATE keiro.keiro_subscription_shards-        SET owner_worker_id = NULL,-            lease_expires_at = NULL,-            updated_at = now()-        WHERE subscription_name = $1-          AND owner_worker_id = $2-          AND bucket = ANY($3)-        """-        ( contrazip3-            (E.param (E.nonNullable E.text))-            (E.param (E.nonNullable E.uuid))-            (E.param (E.nonNullable (E.foldableArray (E.nonNullable E.int4))))-        )-        D.noResult+  preparable+    """+    UPDATE keiro.keiro_subscription_shards+    SET owner_worker_id = NULL,+        lease_expires_at = NULL,+        updated_at = now()+    WHERE subscription_name = $1+      AND owner_worker_id = $2+      AND bucket = ANY($3)+    """+    ( contrazip3+        (E.param (E.nonNullable E.text))+        (E.param (E.nonNullable E.uuid))+        (E.param (E.nonNullable (E.foldableArray (E.nonNullable E.int4))))+    )+    D.noResult  listShardOwnershipStmt :: Statement Text [(Int, Maybe WorkerId, Maybe UTCTime)] listShardOwnershipStmt =-    preparable-        """-        SELECT bucket, owner_worker_id, lease_expires_at-        FROM keiro.keiro_subscription_shards-        WHERE subscription_name = $1-        ORDER BY bucket-        """-        (E.param (E.nonNullable E.text))-        (D.rowList ownershipRowDecoder)+  preparable+    """+    SELECT bucket, owner_worker_id, lease_expires_at+    FROM keiro.keiro_subscription_shards+    WHERE subscription_name = $1+    ORDER BY bucket+    """+    (E.param (E.nonNullable E.text))+    (D.rowList ownershipRowDecoder)  listShardCountsStmt :: Statement Text [(Int, Int)] listShardCountsStmt =-    preparable-        """-        SELECT shard_count, count(*)::int-        FROM keiro.keiro_subscription_shards-        WHERE subscription_name = $1-        GROUP BY shard_count-        ORDER BY shard_count-        """-        (E.param (E.nonNullable E.text))-        (D.rowList ((,) <$> (fromIntegral <$> D.column (D.nonNullable D.int4)) <*> (fromIntegral <$> D.column (D.nonNullable D.int4))))+  preparable+    """+    SELECT shard_count, count(*)::int+    FROM keiro.keiro_subscription_shards+    WHERE subscription_name = $1+    GROUP BY shard_count+    ORDER BY shard_count+    """+    (E.param (E.nonNullable E.text))+    (D.rowList ((,) <$> (fromIntegral <$> D.column (D.nonNullable D.int4)) <*> (fromIntegral <$> D.column (D.nonNullable D.int4))))  ownershipRowDecoder :: D.Row (Int, Maybe WorkerId, Maybe UTCTime) ownershipRowDecoder =-    (,,)-        <$> (fromIntegral <$> D.column (D.nonNullable D.int4))-        <*> (fmap WorkerId <$> D.column (D.nullable D.uuid))-        <*> D.column (D.nullable D.timestamptz)+  (,,)+    <$> (fromIntegral <$> D.column (D.nonNullable D.int4))+    <*> (fmap WorkerId <$> D.column (D.nullable D.uuid))+    <*> D.column (D.nullable D.timestamptz)
src/Keiro/Subscription/Shard/Worker.hs view
@@ -1,69 +1,68 @@-{- | The sharded category-subscription worker: a rebalance loop that turns-leased bucket ownership ("Keiro.Subscription.Shard") into running kiroku-consumer-group readers (EP-51).--Start the __same__ worker binary @N@ times — on @N@ hosts, in @N@ containers, in-an autoscaling group — each calling 'runShardedSubscriptionGroup' with the same-'SubscriptionName' and 'ShardedWorkerOptions', and the workers cooperatively-partition the category among themselves: every event is processed at least once-and none are skipped. A brief ownership overlap can deliver an event more than-once, so handlers must be idempotent. No external coordinator-(etcd/ZooKeeper/Consul) — coordination lives in the-@keiro_subscription_shards@ lease table.--== One pass--'reconcileShardsOnce' is the single testable unit (like-'Keiro.Workflow.Resume.resumeWorkflowsOnce'):--1. Estimate how many workers are live from the lease table.-2. 'Keiro.Subscription.Shard.acquireOwnedBuckets' — renew the leases this worker-   still holds and claim up to a fair share more (taking over expired leases).-3. __Shed__ any buckets held beyond the fair share when more than one worker is-   live, so a worker that grabbed too many on a cold start (when it briefly-   believed it was alone) gives the excess back and the pool converges to an-   even split. A lone worker never sheds — it must own every bucket.-4. Reconcile readers: open a kiroku consumer-group reader for each newly-owned-   bucket, stop the reader for each newly-lost bucket. A bucket that moves owners-   resumes at its own kiroku per-member checkpoint. Each event is acknowledged-   only after its handler returns, so a shed bucket's checkpoint never covers an-   unprocessed event and no event is dropped.--'runShardedSubscriptionGroup' is the loop driver: mint a 'WorkerId', ensure the-shard rows exist, then run 'reconcileShardsOnce' every @renewInterval@ forever.-On graceful shutdown (the loop thread is killed and can run cleanup) a @finally@-stops every reader this worker holds and relinquishes its leases so another-worker can claim immediately. A real process crash still recovers by lease-expiry.--== Why @IO@, not @Eff@--Like 'Keiro.Workflow.Resume.runWorkflowResumeWorkerPush', this worker manages-long-lived 'Control.Concurrent' reader threads and takes the 'KirokuStore' handle-directly (each lease pass runs through 'Kiroku.Store.Effect.runStoreIO'), so its-natural home is 'IO'. The compatibility handler is an ordinary-@'RecordedEvent' -> 'IO' ()@; 'runShardedSubscriptionGroupAck' exposes the-per-event 'ShardAck' surface for handlers that need an explicit retry or-dead-letter decision. A sharded subscription delivers at-least-once (a brief-overlap is possible while a bucket changes owners), so the handler must be-idempotent — keyed on @eventId@ — exactly as keiro's async-projection guidance-already requires.--A synchronous exception from either handler is retried in place according to-'retryPolicy', using 'handlerRetryDelay'. Exhausting the bounded delivery budget-records the event in kiroku's @kiroku.dead_letters@ table and advances to the next-event. 'ShardReaderDied' therefore reports stream-level failures, not ordinary-handler exceptions. An asynchronous exception from shedding or shutdown writes-no acknowledgement, so the event is redelivered by the next owner.--A zombie worker that misses renewals past @leaseTtl@ may continue reading briefly-after another worker claims its bucket, which can duplicate deliveries. It cannot-regress the consumer-group checkpoint: kiroku's checkpoint upsert is monotonic-(@GREATEST@), so a late acknowledgement from the laggard never moves progress-backward.--}-module Keiro.Subscription.Shard.Worker (-    -- * Options+-- | The sharded category-subscription worker: a rebalance loop that turns+-- leased bucket ownership ("Keiro.Subscription.Shard") into running kiroku+-- consumer-group readers (EP-51).+--+-- Start the __same__ worker binary @N@ times — on @N@ hosts, in @N@ containers, in+-- an autoscaling group — each calling 'runShardedSubscriptionGroup' with the same+-- 'SubscriptionName' and 'ShardedWorkerOptions', and the workers cooperatively+-- partition the category among themselves: every event is processed at least once+-- and none are skipped. A brief ownership overlap can deliver an event more than+-- once, so handlers must be idempotent. No external coordinator+-- (etcd/ZooKeeper/Consul) — coordination lives in the+-- @keiro_subscription_shards@ lease table.+--+-- == One pass+--+-- 'reconcileShardsOnce' is the single testable unit (like+-- 'Keiro.Workflow.Resume.resumeWorkflowsOnce'):+--+-- 1. Estimate how many workers are live from the lease table.+-- 2. 'Keiro.Subscription.Shard.acquireOwnedBuckets' — renew the leases this worker+--    still holds and claim up to a fair share more (taking over expired leases).+-- 3. __Shed__ any buckets held beyond the fair share when more than one worker is+--    live, so a worker that grabbed too many on a cold start (when it briefly+--    believed it was alone) gives the excess back and the pool converges to an+--    even split. A lone worker never sheds — it must own every bucket.+-- 4. Reconcile readers: open a kiroku consumer-group reader for each newly-owned+--    bucket, stop the reader for each newly-lost bucket. A bucket that moves owners+--    resumes at its own kiroku per-member checkpoint. Each event is acknowledged+--    only after its handler returns, so a shed bucket's checkpoint never covers an+--    unprocessed event and no event is dropped.+--+-- 'runShardedSubscriptionGroup' is the loop driver: mint a 'WorkerId', ensure the+-- shard rows exist, then run 'reconcileShardsOnce' every @renewInterval@ forever.+-- On graceful shutdown (the loop thread is killed and can run cleanup) a @finally@+-- stops every reader this worker holds and relinquishes its leases so another+-- worker can claim immediately. A real process crash still recovers by lease+-- expiry.+--+-- == Why @IO@, not @Eff@+--+-- Like 'Keiro.Workflow.Resume.runWorkflowResumeWorkerPush', this worker manages+-- long-lived 'Control.Concurrent' reader threads and takes the 'KirokuStore' handle+-- directly (each lease pass runs through 'Kiroku.Store.Effect.runStoreIO'), so its+-- natural home is 'IO'. The compatibility handler is an ordinary+-- @'RecordedEvent' -> 'IO' ()@; 'runShardedSubscriptionGroupAck' exposes the+-- per-event 'ShardAck' surface for handlers that need an explicit retry or+-- dead-letter decision. A sharded subscription delivers at-least-once (a brief+-- overlap is possible while a bucket changes owners), so the handler must be+-- idempotent — keyed on @eventId@ — exactly as keiro's async-projection guidance+-- already requires.+--+-- A synchronous exception from either handler is retried in place according to+-- 'retryPolicy', using 'handlerRetryDelay'. Exhausting the bounded delivery budget+-- records the event in kiroku's @kiroku.dead_letters@ table and advances to the next+-- event. 'ShardReaderDied' therefore reports stream-level failures, not ordinary+-- handler exceptions. An asynchronous exception from shedding or shutdown writes+-- no acknowledgement, so the event is redelivered by the next owner.+--+-- A zombie worker that misses renewals past @leaseTtl@ may continue reading briefly+-- after another worker claims its bucket, which can duplicate deliveries. It cannot+-- regress the consumer-group checkpoint: kiroku's checkpoint upsert is monotonic+-- (@GREATEST@), so a late acknowledgement from the laggard never moves progress+-- backward.+module Keiro.Subscription.Shard.Worker+  ( -- * Options     ShardWorkerError (..),     ShardedWorkerOptions (..),     ShardedWorkerConfigError (..),@@ -82,7 +81,7 @@     reconcileShardsOnce,     runShardedSubscriptionGroup,     runShardedSubscriptionGroupAck,-)+  ) where  import Control.Concurrent (forkFinally, killThread, threadDelay)@@ -101,20 +100,20 @@ import Data.Time (NominalDiffTime) import Data.UUID.V4 qualified as UUIDv4 import Keiro.Prelude-import Keiro.Subscription.Shard (-    ShardLease (..),+import Keiro.Subscription.Shard+  ( ShardLease (..),     WorkerId (..),     acquireOwnedBuckets,     ensureShards,     fairShareTarget,     ownershipSnapshot,     relinquish,- )+  ) import Kiroku.Store.Connection (KirokuStore) import Kiroku.Store.Effect (runStoreIO) import Kiroku.Store.Subscription.Stream (AckItem (..), subscriptionAckStream)-import Kiroku.Store.Subscription.Types (-    ConsumerGroup (..),+import Kiroku.Store.Subscription.Types+  ( ConsumerGroup (..),     DeadLetterReason (..),     RetryDelay (..),     RetryPolicy (..),@@ -123,7 +122,7 @@     SubscriptionTarget,     defaultRetryPolicy,     defaultSubscriptionConfig,- )+  ) import Kiroku.Store.Subscription.Types qualified as Sub import Kiroku.Store.Types (RecordedEvent) import Numeric.Natural (Natural)@@ -131,298 +130,291 @@ import Streamly.Data.Stream qualified as Stream  data ShardWorkerError-    = ShardSnapshotFailed !Text-    | ShardAcquireFailed !Text-    | ShardReaderDied !Int !Text-    | ShardEnsureFailed !Text-    deriving stock (Generic, Eq, Show)+  = ShardSnapshotFailed !Text+  | ShardAcquireFailed !Text+  | ShardReaderDied !Int !Text+  | ShardEnsureFailed !Text+  deriving stock (Generic, Eq, Show)  -- | Per-event disposition returned by an acknowledgement-aware shard handler. data ShardAck-    = -- | Processing completed; the checkpoint may advance past this event.-      ShardAckOk-    | -- | Redeliver after the delay, bounded by 'retryPolicy'.-      ShardAckRetry !RetryDelay-    | -- | Record the event in kiroku's dead-letter table and advance immediately.-      ShardAckDeadLetter !DeadLetterReason-    deriving stock (Generic, Eq, Show)+  = -- | Processing completed; the checkpoint may advance past this event.+    ShardAckOk+  | -- | Redeliver after the delay, bounded by 'retryPolicy'.+    ShardAckRetry !RetryDelay+  | -- | Record the event in kiroku's dead-letter table and advance immediately.+    ShardAckDeadLetter !DeadLetterReason+  deriving stock (Generic, Eq, Show)  -- | One delivery to an acknowledgement-aware shard handler. data ShardDelivery = ShardDelivery-    { event :: !RecordedEvent-    -- ^ The delivered event.-    , attempt :: !Word-    -- ^ Zero-based redelivery count: 0 initially, 1 after the first retry, and so on.-    , bucket :: !Int-    -- ^ The consumer-group member owned by this reader.-    }-    deriving stock (Generic, Eq, Show)+  { -- | The delivered event.+    event :: !RecordedEvent,+    -- | Zero-based redelivery count: 0 initially, 1 after the first retry, and so on.+    attempt :: !Word,+    -- | The consumer-group member owned by this reader.+    bucket :: !Int+  }+  deriving stock (Generic, Eq, Show)  type ShardEventHandler = ShardDelivery -> IO ShardAck  -- | How a sharded worker pool runs one subscription. data ShardedWorkerOptions = ShardedWorkerOptions-    { shardCount :: !Int-    -- ^ @N@ buckets, fixed per subscription name (every worker must agree on @N@).-    , leaseTtl :: !NominalDiffTime-    -- ^ How long a claim/renew keeps a bucket before it expires (default 30 s).-    , renewInterval :: !NominalDiffTime-    {- ^ Gap between reconcile passes; well under 'leaseTtl' so a live worker renews-    several times per TTL (default 10 s ⇒ ~3 renews per 30 s TTL). A single-    missed renewal does not lose ownership; a dead worker loses every bucket-    within one TTL.-    -}-    , target :: !SubscriptionTarget-    -- ^ The category (or @AllStreams@) to shard.-    , batchSize :: !Int32-    -- ^ Events per database fetch per bucket reader (default 100).-    , bufferSize :: !Natural-    -- ^ Per-reader bridge queue capacity (default 256; one item is in flight).-    , handlerRetryDelay :: !RetryDelay-    -- ^ Delay before redelivering after a synchronous handler exception (default 1 s).-    , retryPolicy :: !RetryPolicy-    -- ^ Maximum total deliveries before retry exhaustion dead-letters the event.-    , onShardError :: !(Maybe (ShardWorkerError -> IO ()))-    -- ^ Optional error hook. Wire this to the application logger in production.-    }-    deriving stock (Generic)+  { -- | @N@ buckets, fixed per subscription name (every worker must agree on @N@).+    shardCount :: !Int,+    -- | How long a claim/renew keeps a bucket before it expires (default 30 s).+    leaseTtl :: !NominalDiffTime,+    -- | Gap between reconcile passes; well under 'leaseTtl' so a live worker renews+    --     several times per TTL (default 10 s ⇒ ~3 renews per 30 s TTL). A single+    --     missed renewal does not lose ownership; a dead worker loses every bucket+    --     within one TTL.+    renewInterval :: !NominalDiffTime,+    -- | The category (or @AllStreams@) to shard.+    target :: !SubscriptionTarget,+    -- | Events per database fetch per bucket reader (default 100).+    batchSize :: !Int32,+    -- | Per-reader bridge queue capacity (default 256; one item is in flight).+    bufferSize :: !Natural,+    -- | Delay before redelivering after a synchronous handler exception (default 1 s).+    handlerRetryDelay :: !RetryDelay,+    -- | Maximum total deliveries before retry exhaustion dead-letters the event.+    retryPolicy :: !RetryPolicy,+    -- | Optional error hook. Wire this to the application logger in production.+    onShardError :: !(Maybe (ShardWorkerError -> IO ()))+  }+  deriving stock (Generic)  data ShardedWorkerConfigError-    = InvalidShardCount !Int-    | InvalidShardLeaseTtl !NominalDiffTime-    | InvalidShardRenewInterval !NominalDiffTime-    | InvalidShardLeaseRenewInterval !NominalDiffTime !NominalDiffTime-    | InvalidShardBatchSize !Int32-    | InvalidShardBufferSize !Natural-    | InvalidShardHandlerRetryDelay !RetryDelay-    | InvalidShardRetryMaxAttempts !Int-    deriving stock (Generic, Eq, Show)+  = InvalidShardCount !Int+  | InvalidShardLeaseTtl !NominalDiffTime+  | InvalidShardRenewInterval !NominalDiffTime+  | InvalidShardLeaseRenewInterval !NominalDiffTime !NominalDiffTime+  | InvalidShardBatchSize !Int32+  | InvalidShardBufferSize !Natural+  | InvalidShardHandlerRetryDelay !RetryDelay+  | InvalidShardRetryMaxAttempts !Int+  deriving stock (Generic, Eq, Show) -{- | Sensible defaults for a sharded worker: 30 s lease, 10 s renew, batch 100,-buffer 256. Supply the category target and the bucket count @N@.--}+-- | Sensible defaults for a sharded worker: 30 s lease, 10 s renew, batch 100,+-- buffer 256. Supply the category target and the bucket count @N@. defaultShardedWorkerOptions :: SubscriptionTarget -> Int -> ShardedWorkerOptions defaultShardedWorkerOptions target' shardCount' =-    ShardedWorkerOptions-        { shardCount = shardCount'-        , leaseTtl = 30-        , renewInterval = 10-        , target = target'-        , batchSize = 100-        , bufferSize = 256-        , handlerRetryDelay = RetryDelay 1-        , retryPolicy = defaultRetryPolicy-        , onShardError = Nothing-        }+  ShardedWorkerOptions+    { shardCount = shardCount',+      leaseTtl = 30,+      renewInterval = 10,+      target = target',+      batchSize = 100,+      bufferSize = 256,+      handlerRetryDelay = RetryDelay 1,+      retryPolicy = defaultRetryPolicy,+      onShardError = Nothing+    }  -- | Validate sharded worker options before starting a worker pool member. mkShardedWorkerOptions :: ShardedWorkerOptions -> Either ShardedWorkerConfigError ShardedWorkerOptions mkShardedWorkerOptions opts-    | opts ^. #shardCount < 1 = Left (InvalidShardCount (opts ^. #shardCount))-    | opts ^. #leaseTtl <= 0 = Left (InvalidShardLeaseTtl (opts ^. #leaseTtl))-    | opts ^. #renewInterval <= 0 = Left (InvalidShardRenewInterval (opts ^. #renewInterval))-    | opts ^. #leaseTtl <= opts ^. #renewInterval =-        Left (InvalidShardLeaseRenewInterval (opts ^. #leaseTtl) (opts ^. #renewInterval))-    | opts ^. #batchSize < 1 = Left (InvalidShardBatchSize (opts ^. #batchSize))-    | opts ^. #bufferSize < 1 = Left (InvalidShardBufferSize (opts ^. #bufferSize))-    | RetryDelay delay <- opts ^. #handlerRetryDelay-    , delay < 0 =-        Left (InvalidShardHandlerRetryDelay (opts ^. #handlerRetryDelay))-    | RetryPolicy attempts <- opts ^. #retryPolicy-    , attempts < 1 =-        Left (InvalidShardRetryMaxAttempts attempts)-    | otherwise = Right opts+  | opts ^. #shardCount < 1 = Left (InvalidShardCount (opts ^. #shardCount))+  | opts ^. #leaseTtl <= 0 = Left (InvalidShardLeaseTtl (opts ^. #leaseTtl))+  | opts ^. #renewInterval <= 0 = Left (InvalidShardRenewInterval (opts ^. #renewInterval))+  | opts ^. #leaseTtl <= opts ^. #renewInterval =+      Left (InvalidShardLeaseRenewInterval (opts ^. #leaseTtl) (opts ^. #renewInterval))+  | opts ^. #batchSize < 1 = Left (InvalidShardBatchSize (opts ^. #batchSize))+  | opts ^. #bufferSize < 1 = Left (InvalidShardBufferSize (opts ^. #bufferSize))+  | RetryDelay delay <- opts ^. #handlerRetryDelay,+    delay < 0 =+      Left (InvalidShardHandlerRetryDelay (opts ^. #handlerRetryDelay))+  | RetryPolicy attempts <- opts ^. #retryPolicy,+    attempts < 1 =+      Left (InvalidShardRetryMaxAttempts attempts)+  | otherwise = Right opts -{- | A live per-bucket reader: the action that stops it (cancels the kiroku-subscription and kills the drain thread).--}+-- | A live per-bucket reader: the action that stops it (cancels the kiroku+-- subscription and kills the drain thread). newtype RunningReader = RunningReader {stopReader :: IO ()}  reportShardError :: ShardedWorkerOptions -> ShardWorkerError -> IO () reportShardError opts err =-    for_ (opts ^. #onShardError) ($ err)+  for_ (opts ^. #onShardError) ($ err)  acquireOutcome :: Set Int -> Either Text (Set Int) -> (Set Int, Maybe ShardWorkerError) acquireOutcome previous = \case-    Right owned -> (owned, Nothing)-    Left err -> (previous, Just (ShardAcquireFailed err))--{- | Run one ownership-reconcile pass and bring the set of running readers in-line with the buckets owned afterwards. Returns the buckets this worker owns-after the pass. The @readers@ ref maps each owned bucket to its live reader.+  Right owned -> (owned, Nothing)+  Left err -> (previous, Just (ShardAcquireFailed err)) -This is the testable unit: a single call claims/renews/sheds leases and-starts/stops readers once, with no loop of its own.--}+-- | Run one ownership-reconcile pass and bring the set of running readers in+-- line with the buckets owned afterwards. Returns the buckets this worker owns+-- after the pass. The @readers@ ref maps each owned bucket to its live reader.+--+-- This is the testable unit: a single call claims/renews/sheds leases and+-- starts/stops readers once, with no loop of its own. reconcileShardsOnce ::-    KirokuStore ->-    ShardLease ->-    ShardedWorkerOptions ->-    IORef (Map Int RunningReader) ->-    ShardEventHandler ->-    IO (Set Int)+  KirokuStore ->+  ShardLease ->+  ShardedWorkerOptions ->+  IORef (Map Int RunningReader) ->+  ShardEventHandler ->+  IO (Set Int) reconcileShardsOnce store lease opts readers handler = do-    now <- getCurrentTime-    current <- readIORef readers-    -- Estimate live workers: distinct owners with a non-expired lease, plus self.-    snapResult <- runStoreIO store (ownershipSnapshot lease)-    snap <- case snapResult of-        Right rows -> pure rows-        Left err -> do-            reportShardError opts (ShardSnapshotFailed (Text.pack (show err)))-            pure []-    let liveOwners = Set.fromList [w | (_, Just w, Just expiresAt) <- snap, expiresAt > now]-        liveWorkers = Set.size (Set.insert (lease ^. #workerId) liveOwners)-        shareTarget = fairShareTarget (lease ^. #shardCount) liveWorkers-    -- Renew held + claim up to fair share.-    claimedResult <- runStoreIO store (acquireOwnedBuckets lease liveWorkers)-    let previousOwned = Map.keysSet current-        (claimed, mAcquireError) = acquireOutcome previousOwned (first (Text.pack . show) claimedResult)-    for_ mAcquireError (reportShardError opts)-    -- Shed any excess above the fair share so a cold-start over-claim self-balances-    -- (never when alone: a lone worker must own everything).-    owned <--        if liveWorkers > 1 && Set.size claimed > shareTarget-            then do-                let excess = Set.fromList (drop shareTarget (sort (Set.toList claimed)))-                _ <- runStoreIO store (relinquish lease excess)-                pure (claimed `Set.difference` excess)-            else pure claimed-    -- Bring readers in line with `owned`: start newly-owned, stop newly-lost.-    let running = Map.keysSet current-        toStart = owned `Set.difference` running-        toStop = running `Set.difference` owned-    for_ (Set.toList toStop) $ \bucket ->-        for_ (Map.lookup bucket current) stopReader-    started <--        traverse-            (\bucket -> (,) bucket <$> startReader store lease opts readers handler bucket)-            (Set.toList toStart)-    atomicModifyIORef' readers $ \m ->-        let afterStop = foldr Map.delete m (Set.toList toStop)-            afterStart = foldr (\(b, r) -> Map.insert b r) afterStop started-         in (afterStart, ())-    pure owned+  now <- getCurrentTime+  current <- readIORef readers+  -- Estimate live workers: distinct owners with a non-expired lease, plus self.+  snapResult <- runStoreIO store (ownershipSnapshot lease)+  snap <- case snapResult of+    Right rows -> pure rows+    Left err -> do+      reportShardError opts (ShardSnapshotFailed (Text.pack (show err)))+      pure []+  let liveOwners = Set.fromList [w | (_, Just w, Just expiresAt) <- snap, expiresAt > now]+      liveWorkers = Set.size (Set.insert (lease ^. #workerId) liveOwners)+      shareTarget = fairShareTarget (lease ^. #shardCount) liveWorkers+  -- Renew held + claim up to fair share.+  claimedResult <- runStoreIO store (acquireOwnedBuckets lease liveWorkers)+  let previousOwned = Map.keysSet current+      (claimed, mAcquireError) = acquireOutcome previousOwned (first (Text.pack . show) claimedResult)+  for_ mAcquireError (reportShardError opts)+  -- Shed any excess above the fair share so a cold-start over-claim self-balances+  -- (never when alone: a lone worker must own everything).+  owned <-+    if liveWorkers > 1 && Set.size claimed > shareTarget+      then do+        let excess = Set.fromList (drop shareTarget (sort (Set.toList claimed)))+        _ <- runStoreIO store (relinquish lease excess)+        pure (claimed `Set.difference` excess)+      else pure claimed+  -- Bring readers in line with `owned`: start newly-owned, stop newly-lost.+  let running = Map.keysSet current+      toStart = owned `Set.difference` running+      toStop = running `Set.difference` owned+  for_ (Set.toList toStop) $ \bucket ->+    for_ (Map.lookup bucket current) stopReader+  started <-+    traverse+      (\bucket -> (,) bucket <$> startReader store lease opts readers handler bucket)+      (Set.toList toStart)+  atomicModifyIORef' readers $ \m ->+    let afterStop = foldr Map.delete m (Set.toList toStop)+        afterStart = foldr (\(b, r) -> Map.insert b r) afterStop started+     in (afterStart, ())+  pure owned -{- | Open a kiroku consumer-group reader for one bucket and fork a thread that-drains it into the handler. The returned 'RunningReader' cancels the-subscription (which terminates the drain) and kills the thread.--}+-- | Open a kiroku consumer-group reader for one bucket and fork a thread that+-- drains it into the handler. The returned 'RunningReader' cancels the+-- subscription (which terminates the drain) and kills the thread. startReader ::-    KirokuStore ->-    ShardLease ->-    ShardedWorkerOptions ->-    IORef (Map Int RunningReader) ->-    ShardEventHandler ->-    Int ->-    IO RunningReader+  KirokuStore ->+  ShardLease ->+  ShardedWorkerOptions ->+  IORef (Map Int RunningReader) ->+  ShardEventHandler ->+  Int ->+  IO RunningReader startReader store lease opts readers handler bucket = do-    stopping <- newIORef False-    let subConfig =-            (defaultSubscriptionConfig (lease ^. #subscriptionName) (opts ^. #target) (\_ -> pure Continue))-                { Sub.batchSize = opts ^. #batchSize-                , Sub.consumerGroup =-                    Just (ConsumerGroup{member = fromIntegral bucket, size = fromIntegral (opts ^. #shardCount)})-                , Sub.retryPolicy = opts ^. #retryPolicy-                }-        handleItem item = do-            outcome <--                handler-                    ShardDelivery-                        { event = ackEvent item-                        , attempt = ackAttempt item-                        , bucket = bucket-                        }-                    `catch` handlerException-            atomically (putTMVar (ackReply item) (toSubscriptionResult outcome))-        handlerException err =-            case fromException err of-                Just async -> throwIO (async :: SomeAsyncException)-                Nothing -> pure (ShardAckRetry (opts ^. #handlerRetryDelay))-    (stream, cancelAction) <- subscriptionAckStream store subConfig (opts ^. #bufferSize)-    tid <--        forkFinally (Stream.fold (Fold.drainMapM handleItem) stream) $ \result -> do-            intentional <- readIORef stopping-            unless intentional $ do-                atomicModifyIORef' readers (\m -> (Map.delete bucket m, ()))-                let reason = case result of-                        Left err -> Text.pack (displayException (err :: SomeException))-                        Right _ -> "reader stream ended"-                reportShardError opts (ShardReaderDied bucket reason)-    pure-        ( RunningReader $ do-            writeIORef stopping True-            cancelAction-            killThread tid-        )+  stopping <- newIORef False+  let subConfig =+        (defaultSubscriptionConfig (lease ^. #subscriptionName) (opts ^. #target) (\_ -> pure Continue))+          { Sub.batchSize = opts ^. #batchSize,+            Sub.consumerGroup =+              Just (ConsumerGroup {member = fromIntegral bucket, size = fromIntegral (opts ^. #shardCount)}),+            Sub.retryPolicy = opts ^. #retryPolicy+          }+      handleItem item = do+        outcome <-+          handler+            ShardDelivery+              { event = ackEvent item,+                attempt = ackAttempt item,+                bucket = bucket+              }+            `catch` handlerException+        atomically (putTMVar (ackReply item) (toSubscriptionResult outcome))+      handlerException err =+        case fromException err of+          Just async -> throwIO (async :: SomeAsyncException)+          Nothing -> pure (ShardAckRetry (opts ^. #handlerRetryDelay))+  (stream, cancelAction) <- subscriptionAckStream store subConfig (opts ^. #bufferSize)+  tid <-+    forkFinally (Stream.fold (Fold.drainMapM handleItem) stream) $ \result -> do+      intentional <- readIORef stopping+      unless intentional $ do+        atomicModifyIORef' readers (\m -> (Map.delete bucket m, ()))+        let reason = case result of+              Left err -> Text.pack (displayException (err :: SomeException))+              Right _ -> "reader stream ended"+        reportShardError opts (ShardReaderDied bucket reason)+  pure+    ( RunningReader $ do+        writeIORef stopping True+        cancelAction+        killThread tid+    )  toSubscriptionResult :: ShardAck -> SubscriptionResult toSubscriptionResult = \case-    ShardAckOk -> Continue-    ShardAckRetry delay -> Retry delay-    ShardAckDeadLetter reason -> DeadLetter reason--{- | The loop driver: mint a 'WorkerId', ensure the @N@ shard rows exist, then-'reconcileShardsOnce' every @renewInterval@ forever. On shutdown (the loop thread-is killed) a @finally@ stops every reader this worker holds, so a crashed-worker's buckets stop being read immediately; its leases then expire and a-surviving worker re-claims them.+  ShardAckOk -> Continue+  ShardAckRetry delay -> Retry delay+  ShardAckDeadLetter reason -> DeadLetter reason -The fixed @renewInterval@ between passes (the 'threadDelay' in 'loop') is the-__rebalance-signal seam__ (EP-51 Milestone 6). The shipped default is a pure poll:-correctness — disjointness and failover — rests entirely on the lease table and-does not depend on any notification. The EP-50 'Keiro.Wake' channel wakes on event-/appends/ (@kiroku.events@), which is a different event than a shard ownership-/change/; signalling a prompt rebalance on a worker join or a voluntary relinquish-would ride a dedicated @keiro_shard_rebalance@ @NOTIFY@ fired on claim/release, and-the swap is local to this one 'threadDelay' (replace it with a bounded wait on that-channel, exactly as 'Keiro.Workflow.Resume.runPollLoopWith' does for appends). Left-as the poll default here because it is a latency optimisation, not a correctness-requirement.--}+-- | The loop driver: mint a 'WorkerId', ensure the @N@ shard rows exist, then+-- 'reconcileShardsOnce' every @renewInterval@ forever. On shutdown (the loop thread+-- is killed) a @finally@ stops every reader this worker holds, so a crashed+-- worker's buckets stop being read immediately; its leases then expire and a+-- surviving worker re-claims them.+--+-- The fixed @renewInterval@ between passes (the 'threadDelay' in 'loop') is the+-- __rebalance-signal seam__ (EP-51 Milestone 6). The shipped default is a pure poll:+-- correctness — disjointness and failover — rests entirely on the lease table and+-- does not depend on any notification. The EP-50 'Keiro.Wake' channel wakes on event+-- /appends/ (@kiroku.events@), which is a different event than a shard ownership+-- /change/; signalling a prompt rebalance on a worker join or a voluntary relinquish+-- would ride a dedicated @keiro_shard_rebalance@ @NOTIFY@ fired on claim/release, and+-- the swap is local to this one 'threadDelay' (replace it with a bounded wait on that+-- channel, exactly as 'Keiro.Workflow.Resume.runPollLoopWith' does for appends). Left+-- as the poll default here because it is a latency optimisation, not a correctness+-- requirement. runShardedSubscriptionGroup ::-    KirokuStore ->-    SubscriptionName ->-    ShardedWorkerOptions ->-    (RecordedEvent -> IO ()) ->-    IO ()+  KirokuStore ->+  SubscriptionName ->+  ShardedWorkerOptions ->+  (RecordedEvent -> IO ()) ->+  IO () runShardedSubscriptionGroup store subName opts handler =-    runShardedSubscriptionGroupAck store subName opts $ \delivery -> do-        handler (delivery ^. #event)-        pure ShardAckOk+  runShardedSubscriptionGroupAck store subName opts $ \delivery -> do+    handler (delivery ^. #event)+    pure ShardAckOk -{- | Acknowledgement-aware loop driver. Unlike the compatibility wrapper, the-handler decides whether each event advances, retries, or dead-letters.--}+-- | Acknowledgement-aware loop driver. Unlike the compatibility wrapper, the+-- handler decides whether each event advances, retries, or dead-letters. runShardedSubscriptionGroupAck ::-    KirokuStore ->-    SubscriptionName ->-    ShardedWorkerOptions ->-    ShardEventHandler ->-    IO ()+  KirokuStore ->+  SubscriptionName ->+  ShardedWorkerOptions ->+  ShardEventHandler ->+  IO () runShardedSubscriptionGroupAck store subName opts handler = do-    worker <- WorkerId <$> UUIDv4.nextRandom-    let lease =-            ShardLease-                { subscriptionName = subName-                , workerId = worker-                , shardCount = opts ^. #shardCount-                , leaseTtl = opts ^. #leaseTtl-                }-    ensured <- runStoreIO store (ensureShards lease)-    case ensured of-        Right () -> pure ()-        Left err -> reportShardError opts (ShardEnsureFailed (Text.pack (show err)))-    readers <- newIORef Map.empty-    loop lease readers `finally` cleanup lease readers+  worker <- WorkerId <$> UUIDv4.nextRandom+  let lease =+        ShardLease+          { subscriptionName = subName,+            workerId = worker,+            shardCount = opts ^. #shardCount,+            leaseTtl = opts ^. #leaseTtl+          }+  ensured <- runStoreIO store (ensureShards lease)+  case ensured of+    Right () -> pure ()+    Left err -> reportShardError opts (ShardEnsureFailed (Text.pack (show err)))+  readers <- newIORef Map.empty+  loop lease readers `finally` cleanup lease readers   where     delayMicros = max 1 (round (realToFrac (opts ^. #renewInterval) * 1e6 :: Double))     loop lease readers =-        forever $ do-            _ <- reconcileShardsOnce store lease opts readers handler-            threadDelay delayMicros+      forever $ do+        _ <- reconcileShardsOnce store lease opts readers handler+        threadDelay delayMicros     cleanup lease readers = do-        current <- readIORef readers-        for_ (Map.elems current) stopReader-        _ <- runStoreIO store (relinquish lease (Map.keysSet current))-        pure ()+      current <- readIORef readers+      for_ (Map.elems current) stopReader+      _ <- runStoreIO store (relinquish lease (Map.keysSet current))+      pure ()
src/Keiro/Telemetry.hs view
@@ -1,31 +1,30 @@-{- | Thin OpenTelemetry surface for the keiro library.--This module is the single place keiro reaches for @hs-opentelemetry-api@-and @hs-opentelemetry-semantic-conventions@. Callers configure a 'Tracer'-on the application side (typically via @hs-opentelemetry-sdk@'s-'OpenTelemetry.Trace.makeTracer'), then pass it through to keiro's-publisher / consumer / command surfaces.--When no tracer is supplied, every helper degrades to a thin pass-through-(it calls the body and returns its value), so applications that do not-yet wire OpenTelemetry are unaffected.--# Attribute keys--keiro links @hs-opentelemetry-semantic-conventions@ @1.40.0.0@ (generated-from spec @v1.40@) directly. Every messaging.* / db.* typed 'AttributeKey'-the keiro audit cites (@docs/research/opentelemetry-semconv-audit.md@) is-imported from @OpenTelemetry.SemanticConventions@ and re-exported from this-module, so 'Keiro.Telemetry' remains the one-stop telemetry surface for the-library while every convention name is anchored to the spec-generated module-rather than a hand-typed string.--Only the @keiro.*@ keys ('keiro_stream_name', 'keiro_retry_attempt',-'keiro_events_appended', 'keiro_replay_divergence') are defined locally: they-are bespoke to keiro and have no upstream equivalent.--}-module Keiro.Telemetry (-    -- * Span helpers+-- | Thin OpenTelemetry surface for the keiro library.+--+-- This module is the single place keiro reaches for @hs-opentelemetry-api@+-- and @hs-opentelemetry-semantic-conventions@. Callers configure a 'Tracer'+-- on the application side (typically via @hs-opentelemetry-sdk@'s+-- 'OpenTelemetry.Trace.makeTracer'), then pass it through to keiro's+-- publisher / consumer / command surfaces.+--+-- When no tracer is supplied, every helper degrades to a thin pass-through+-- (it calls the body and returns its value), so applications that do not+-- yet wire OpenTelemetry are unaffected.+--+-- # Attribute keys+--+-- keiro links @hs-opentelemetry-semantic-conventions@ @1.40.0.0@ (generated+-- from spec @v1.40@) directly. Every messaging.* / db.* typed 'AttributeKey'+-- the keiro audit cites (@docs/research/opentelemetry-semconv-audit.md@) is+-- imported from @OpenTelemetry.SemanticConventions@ and re-exported from this+-- module, so 'Keiro.Telemetry' remains the one-stop telemetry surface for the+-- library while every convention name is anchored to the spec-generated module+-- rather than a hand-typed string.+--+-- Only the @keiro.*@ keys ('keiro_stream_name', 'keiro_retry_attempt',+-- 'keiro_events_appended', 'keiro_replay_divergence') are defined locally: they+-- are bespoke to keiro and have no upstream equivalent.+module Keiro.Telemetry+  ( -- * Span helpers     Tracer,     withProducerSpan,     withConsumerSpan,@@ -155,22 +154,33 @@      -- * Kiroku observability bridge     kirokuEventBridge,-)+  ) where +import Keiro.Inbox.Kafka (KafkaInboundRecord)+import Keiro.Integration.Event+  ( IntegrationEvent,+    TraceContext (..),+    headerTraceParent,+    headerTraceState,+  )+import Keiro.Outbox.Kafka (KafkaProducerRecord)+import Keiro.Prelude+import Keiro.Workflow.Types (StepName (..), WorkflowId (..), WorkflowName (..))+import Kiroku.Store.Observability (KirokuEvent (..)) import "base" Control.Exception (bracket) import "base" GHC.Stack (HasCallStack) import "bytestring" Data.ByteString qualified as ByteString import "hs-opentelemetry-api" OpenTelemetry.Attributes (emptyAttributes) import "hs-opentelemetry-api" OpenTelemetry.Attributes.Key (AttributeKey (..)) import "hs-opentelemetry-api" OpenTelemetry.Context (insertSpan, lookupSpan)-import "hs-opentelemetry-api" OpenTelemetry.Context.ThreadLocal (-    attachContext,+import "hs-opentelemetry-api" OpenTelemetry.Context.ThreadLocal+  ( attachContext,     detachContext,     getContext,- )-import "hs-opentelemetry-api" OpenTelemetry.Metric.Core (-    Counter,+  )+import "hs-opentelemetry-api" OpenTelemetry.Metric.Core+  ( Counter,     Gauge,     Histogram,     Meter,@@ -181,9 +191,9 @@     meterCreateCounterInt64,     meterCreateGaugeInt64,     meterCreateHistogram,- )-import "hs-opentelemetry-api" OpenTelemetry.Trace.Core (-    InstrumentationLibrary (..),+  )+import "hs-opentelemetry-api" OpenTelemetry.Trace.Core+  ( InstrumentationLibrary (..),     Span,     SpanArguments (..),     SpanKind (..),@@ -192,9 +202,13 @@     defaultSpanArguments,     inSpan',     wrapSpanContext,- )-import "hs-opentelemetry-semantic-conventions" OpenTelemetry.SemanticConventions (-    db_collection_name,+  )+import "hs-opentelemetry-propagator-w3c" OpenTelemetry.Propagator.W3CTraceContext+  ( decodeSpanContext,+    encodeSpanContext,+  )+import "hs-opentelemetry-semantic-conventions" OpenTelemetry.SemanticConventions+  ( db_collection_name,     db_namespace,     db_operation_name,     db_system_name,@@ -208,42 +222,24 @@     messaging_operation_name,     messaging_operation_type,     messaging_system,- )+  ) import "text" Data.Text qualified as Text import "text" Data.Text.Encoding qualified as TE import "unliftio-core" Control.Monad.IO.Unlift (MonadUnliftIO, withRunInIO) -import Keiro.Inbox.Kafka (KafkaInboundRecord)-import Keiro.Integration.Event (-    IntegrationEvent,-    TraceContext (..),-    headerTraceParent,-    headerTraceState,- )-import Keiro.Outbox.Kafka (KafkaProducerRecord)-import Keiro.Prelude-import Keiro.Workflow.Types (StepName (..), WorkflowId (..), WorkflowName (..))-import Kiroku.Store.Observability (KirokuEvent (..))--import "hs-opentelemetry-propagator-w3c" OpenTelemetry.Propagator.W3CTraceContext (-    decodeSpanContext,-    encodeSpanContext,- )- -- --------------------------------------------------------------------------- -- Bespoke keiro AttributeKeys -- --------------------------------------------------------------------------- -{- $semconv_keys-The messaging.* / db.* 'AttributeKey's re-exported here are imported-directly from 'OpenTelemetry.SemanticConventions'-(@hs-opentelemetry-semantic-conventions@ @1.40.0.0@). They are surfaced-from this module so 'Keiro.Telemetry' stays the single telemetry import-for the library; their definitions live upstream.--The @keiro_*@ keys below are bespoke to keiro and have no upstream-equivalent, so they are defined locally.--}+-- $semconv_keys+-- The messaging.* / db.* 'AttributeKey's re-exported here are imported+-- directly from 'OpenTelemetry.SemanticConventions'+-- (@hs-opentelemetry-semantic-conventions@ @1.40.0.0@). They are surfaced+-- from this module so 'Keiro.Telemetry' stays the single telemetry import+-- for the library; their definitions live upstream.+--+-- The @keiro_*@ keys below are bespoke to keiro and have no upstream+-- equivalent, so they are defined locally.  keiro_stream_name :: AttributeKey Text keiro_stream_name = AttributeKey "keiro.stream.name"@@ -270,246 +266,238 @@ -- Span helpers -- --------------------------------------------------------------------------- -{- | Run @body@ inside a @Producer@-kind span named @"send " <> destination@-populated with the messaging attributes prescribed by-@docs/research/opentelemetry-semconv-audit.md@ for the outbox publish-site.--When the supplied 'Tracer' is 'Nothing', the body runs unwrapped and the-helper is a no-op pass-through. This keeps the cost of the helper at-"one 'Maybe' branch" for applications that have not yet configured a-tracer.--The body receives the producer 'Span' so it can record a publish failure-via 'recordPublishError'.--}+-- | Run @body@ inside a @Producer@-kind span named @"send " <> destination@+-- populated with the messaging attributes prescribed by+-- @docs/research/opentelemetry-semconv-audit.md@ for the outbox publish+-- site.+--+-- When the supplied 'Tracer' is 'Nothing', the body runs unwrapped and the+-- helper is a no-op pass-through. This keeps the cost of the helper at+-- "one 'Maybe' branch" for applications that have not yet configured a+-- tracer.+--+-- The body receives the producer 'Span' so it can record a publish failure+-- via 'recordPublishError'. withProducerSpan ::-    (MonadUnliftIO m, HasCallStack) =>-    Maybe Tracer ->-    IntegrationEvent ->-    KafkaProducerRecord ->-    (Maybe Span -> m a) ->-    m a+  (MonadUnliftIO m, HasCallStack) =>+  Maybe Tracer ->+  IntegrationEvent ->+  KafkaProducerRecord ->+  (Maybe Span -> m a) ->+  m a withProducerSpan Nothing _ _ body = body Nothing withProducerSpan (Just tracer) event record body =-    inSpan' tracer name args $ \sp -> do-        setProducerAttributes sp event record-        body (Just sp)+  inSpan' tracer name args $ \sp -> do+    setProducerAttributes sp event record+    body (Just sp)   where     name = "send " <> (event ^. #destination)-    args = defaultSpanArguments{kind = Producer}--{- | Run @body@ inside a @Consumer@-kind span named @"process " <> topic@.--Like 'withProducerSpan', the helper is a pass-through under a 'Nothing'-tracer. The 'KafkaInboundRecord' is required so the helper can populate-@messaging.kafka.offset@ and @messaging.destination.partition.id@-without the caller threading them separately.+    args = defaultSpanArguments {kind = Producer} -The optional 'Text' is a consumer group name, recorded as-@messaging.consumer.group.name@ when present. The 'IntegrationEvent' is-attached when present (decode succeeded), so @messaging.message.id@-is set; otherwise the helper records only the headers known from the-broker record.--}+-- | Run @body@ inside a @Consumer@-kind span named @"process " <> topic@.+--+-- Like 'withProducerSpan', the helper is a pass-through under a 'Nothing'+-- tracer. The 'KafkaInboundRecord' is required so the helper can populate+-- @messaging.kafka.offset@ and @messaging.destination.partition.id@+-- without the caller threading them separately.+--+-- The optional 'Text' is a consumer group name, recorded as+-- @messaging.consumer.group.name@ when present. The 'IntegrationEvent' is+-- attached when present (decode succeeded), so @messaging.message.id@+-- is set; otherwise the helper records only the headers known from the+-- broker record. withConsumerSpan ::-    (MonadUnliftIO m, HasCallStack) =>-    Maybe Tracer ->-    -- | consumer group name (optional)-    Maybe Text ->-    KafkaInboundRecord ->-    -- | decoded envelope; 'Nothing' on a decode failure path-    Maybe IntegrationEvent ->-    (Maybe Span -> m a) ->-    m a+  (MonadUnliftIO m, HasCallStack) =>+  Maybe Tracer ->+  -- | consumer group name (optional)+  Maybe Text ->+  KafkaInboundRecord ->+  -- | decoded envelope; 'Nothing' on a decode failure path+  Maybe IntegrationEvent ->+  (Maybe Span -> m a) ->+  m a withConsumerSpan Nothing _ _ _ body = body Nothing withConsumerSpan (Just tracer) consumerGroup record mEvent body =-    withRemoteParent (record ^. #headers) $-        inSpan' tracer name args $ \sp -> do-            setConsumerAttributes sp consumerGroup record mEvent-            body (Just sp)+  withRemoteParent (record ^. #headers) $+    inSpan' tracer name args $ \sp -> do+      setConsumerAttributes sp consumerGroup record mEvent+      body (Just sp)   where     name = "process " <> (record ^. #topic)-    args = defaultSpanArguments{kind = Consumer}--{- | Run @body@ with the OpenTelemetry context temporarily augmented by a-parent span extracted from the supplied header list via the W3C-TraceContext propagator.--When no @traceparent@ header is present (or it cannot be parsed) the-body runs unwrapped, so the helper is safe to call unconditionally.+    args = defaultSpanArguments {kind = Consumer} -This is the bridge that makes a 'Consumer'-kind span open in this-process a *child* of the 'Producer'-kind span that emitted the message-in the upstream process, joining the two traces by trace id.--}+-- | Run @body@ with the OpenTelemetry context temporarily augmented by a+-- parent span extracted from the supplied header list via the W3C+-- TraceContext propagator.+--+-- When no @traceparent@ header is present (or it cannot be parsed) the+-- body runs unwrapped, so the helper is safe to call unconditionally.+--+-- This is the bridge that makes a 'Consumer'-kind span open in this+-- process a *child* of the 'Producer'-kind span that emitted the message+-- in the upstream process, joining the two traces by trace id. withRemoteParent ::-    (MonadUnliftIO m) => [(Text, Text)] -> m a -> m a+  (MonadUnliftIO m) => [(Text, Text)] -> m a -> m a withRemoteParent hs body =-    case parentSpanContext hs of-        Nothing -> body-        Just spanCtx -> withRunInIO $ \runInIO -> do-            ctx <- getContext-            let newCtx = insertSpan (wrapSpanContext spanCtx) ctx-            bracket-                (attachContext newCtx)-                detachContext-                (const (runInIO body))+  case parentSpanContext hs of+    Nothing -> body+    Just spanCtx -> withRunInIO $ \runInIO -> do+      ctx <- getContext+      let newCtx = insertSpan (wrapSpanContext spanCtx) ctx+      bracket+        (attachContext newCtx)+        detachContext+        (const (runInIO body))   where     parentSpanContext hsList =-        let tp = fmap TE.encodeUtf8 (Prelude.lookup headerTraceParent hsList)-            ts = fmap TE.encodeUtf8 (Prelude.lookup headerTraceState hsList)-         in decodeSpanContext tp ts+      let tp = fmap TE.encodeUtf8 (Prelude.lookup headerTraceParent hsList)+          ts = fmap TE.encodeUtf8 (Prelude.lookup headerTraceState hsList)+       in decodeSpanContext tp ts -{- | Open an @Internal@ span around a command run, named after the resolved-stream identifier. Attributes capture the stream name and (when the-caller supplies it) the retry attempt number. The number of events-appended is attached after a successful append by the caller via-'addAttribute span keiro_events_appended n'.--}+-- | Open an @Internal@ span around a command run, named after the resolved+-- stream identifier. Attributes capture the stream name and (when the+-- caller supplies it) the retry attempt number. The number of events+-- appended is attached after a successful append by the caller via+-- 'addAttribute span keiro_events_appended n'. withCommandSpan ::-    (MonadUnliftIO m, HasCallStack) =>-    Maybe Tracer ->-    -- | resolved stream name-    Text ->-    -- | retry attempt (1-based); 'Nothing' to omit-    Maybe Int64 ->-    (Maybe Span -> m a) ->-    m a+  (MonadUnliftIO m, HasCallStack) =>+  Maybe Tracer ->+  -- | resolved stream name+  Text ->+  -- | retry attempt (1-based); 'Nothing' to omit+  Maybe Int64 ->+  (Maybe Span -> m a) ->+  m a withCommandSpan Nothing _ _ body = body Nothing withCommandSpan (Just tracer) streamName retryAttempt body =-    inSpan' tracer streamName args $ \sp -> do-        addAttribute sp (unkey keiro_stream_name) streamName-        case retryAttempt of-            Nothing -> pure ()-            Just n -> addAttribute sp (unkey keiro_retry_attempt) n-        body (Just sp)+  inSpan' tracer streamName args $ \sp -> do+    addAttribute sp (unkey keiro_stream_name) streamName+    case retryAttempt of+      Nothing -> pure ()+      Just n -> addAttribute sp (unkey keiro_retry_attempt) n+    body (Just sp)   where-    args = defaultSpanArguments{kind = Internal}+    args = defaultSpanArguments {kind = Internal} -{- | Open an @Internal@ span around a workflow run (or a single step/resume when-a 'StepName' is supplied), named @"workflow " <> name@. Attributes carry the-bespoke @keiro.workflow.name@, @keiro.workflow.id@, and — when present —-@keiro.workflow.step@ keys. Like 'withCommandSpan', a 'Nothing' tracer makes the-helper a pass-through, so it is safe to call unconditionally.--}+-- | Open an @Internal@ span around a workflow run (or a single step/resume when+-- a 'StepName' is supplied), named @"workflow " <> name@. Attributes carry the+-- bespoke @keiro.workflow.name@, @keiro.workflow.id@, and — when present —+-- @keiro.workflow.step@ keys. Like 'withCommandSpan', a 'Nothing' tracer makes the+-- helper a pass-through, so it is safe to call unconditionally. withWorkflowSpan ::-    (MonadUnliftIO m, HasCallStack) =>-    Maybe Tracer ->-    WorkflowName ->-    WorkflowId ->-    Maybe StepName ->-    (Maybe Span -> m a) ->-    m a+  (MonadUnliftIO m, HasCallStack) =>+  Maybe Tracer ->+  WorkflowName ->+  WorkflowId ->+  Maybe StepName ->+  (Maybe Span -> m a) ->+  m a withWorkflowSpan Nothing _ _ _ body = body Nothing withWorkflowSpan (Just tracer) name wid mStep body =-    inSpan' tracer spanName args $ \sp -> do-        addAttribute sp (unkey keiro_workflow_name) (unWorkflowName name)-        addAttribute sp (unkey keiro_workflow_id) (unWorkflowId wid)-        case mStep of-            Nothing -> pure ()-            Just s -> addAttribute sp (unkey keiro_workflow_step) (unStepName s)-        body (Just sp)+  inSpan' tracer spanName args $ \sp -> do+    addAttribute sp (unkey keiro_workflow_name) (unWorkflowName name)+    addAttribute sp (unkey keiro_workflow_id) (unWorkflowId wid)+    case mStep of+      Nothing -> pure ()+      Just s -> addAttribute sp (unkey keiro_workflow_step) (unStepName s)+    body (Just sp)   where     spanName = "workflow " <> unWorkflowName name-    args = defaultSpanArguments{kind = Internal}+    args = defaultSpanArguments {kind = Internal}  -- --------------------------------------------------------------------------- -- W3C TraceContext bridge -- --------------------------------------------------------------------------- -{- | Read the current thread-local span context and format it as a-'TraceContext'. Returns 'Nothing' when no span is active on the current-thread.--The application is expected to have already configured the W3C-propagator on its 'TracerProvider' (so the propagator is responsible for-on-the-wire framing); this helper is the keiro-side bridge between the-in-memory span and the keiro 'TraceContext' record stored on-'IntegrationEvent' envelopes and outbox rows.--}+-- | Read the current thread-local span context and format it as a+-- 'TraceContext'. Returns 'Nothing' when no span is active on the current+-- thread.+--+-- The application is expected to have already configured the W3C+-- propagator on its 'TracerProvider' (so the propagator is responsible for+-- on-the-wire framing); this helper is the keiro-side bridge between the+-- in-memory span and the keiro 'TraceContext' record stored on+-- 'IntegrationEvent' envelopes and outbox rows. traceContextFromCurrentSpan :: (MonadIO m) => m (Maybe TraceContext) traceContextFromCurrentSpan = do-    ctx <- getContext-    case lookupSpan ctx of-        Nothing -> pure Nothing-        Just sp -> do-            (traceparentBytes, tracestateBytes) <- liftIO (encodeSpanContext sp)-            let traceparent = TE.decodeUtf8 traceparentBytes-                tracestate-                    | ByteString.null tracestateBytes = Nothing-                    | otherwise = Just (TE.decodeUtf8 tracestateBytes)-            pure (Just (TraceContext traceparent tracestate))+  ctx <- getContext+  case lookupSpan ctx of+    Nothing -> pure Nothing+    Just sp -> do+      (traceparentBytes, tracestateBytes) <- liftIO (encodeSpanContext sp)+      let traceparent = TE.decodeUtf8 traceparentBytes+          tracestate+            | ByteString.null tracestateBytes = Nothing+            | otherwise = Just (TE.decodeUtf8 tracestateBytes)+      pure (Just (TraceContext traceparent tracestate)) -{- | Lift a 'TraceContext' out of a flat @[(Text, Text)]@ header list. This-is the mirror image of 'integrationHeaders': it does not validate the-@traceparent@ format (the W3C propagator's parser does that at consume-time); it merely converts the on-the-wire pair of headers to the keiro-envelope record.--}+-- | Lift a 'TraceContext' out of a flat @[(Text, Text)]@ header list. This+-- is the mirror image of 'integrationHeaders': it does not validate the+-- @traceparent@ format (the W3C propagator's parser does that at consume+-- time); it merely converts the on-the-wire pair of headers to the keiro+-- envelope record. traceContextFromHeaders :: [(Text, Text)] -> Maybe TraceContext traceContextFromHeaders hs = case Prelude.lookup headerTraceParent hs of-    Nothing -> Nothing-    Just tp -> Just (TraceContext tp (Prelude.lookup headerTraceState hs))--{- | Append the W3C @traceparent@ / @tracestate@ headers for the current-thread-local span to the supplied header list. When no span is active-on the current thread, the input list is returned unchanged.+  Nothing -> Nothing+  Just tp -> Just (TraceContext tp (Prelude.lookup headerTraceState hs)) -Used by adapters that build a flat header list from their own envelope-(e.g. the outbox publisher) so the headers carry the active span-context even if the caller did not capture a 'TraceContext' onto the-event explicitly.--}+-- | Append the W3C @traceparent@ / @tracestate@ headers for the current+-- thread-local span to the supplied header list. When no span is active+-- on the current thread, the input list is returned unchanged.+--+-- Used by adapters that build a flat header list from their own envelope+-- (e.g. the outbox publisher) so the headers carry the active span+-- context even if the caller did not capture a 'TraceContext' onto the+-- event explicitly. injectTraceContext :: (MonadIO m) => [(Text, Text)] -> m [(Text, Text)] injectTraceContext hs = do-    mctx <- traceContextFromCurrentSpan-    pure $ case mctx of-        Nothing -> hs-        Just tc ->-            hs-                ++ [(headerTraceParent, tc ^. #traceparent)]-                ++ maybe [] (\ts -> [(headerTraceState, ts)]) (tc ^. #tracestate)+  mctx <- traceContextFromCurrentSpan+  pure $ case mctx of+    Nothing -> hs+    Just tc ->+      hs+        ++ [(headerTraceParent, tc ^. #traceparent)]+        ++ maybe [] (\ts -> [(headerTraceState, ts)]) (tc ^. #tracestate)  -- --------------------------------------------------------------------------- -- Internal helpers -- ---------------------------------------------------------------------------  setProducerAttributes ::-    (MonadIO m) => Span -> IntegrationEvent -> KafkaProducerRecord -> m ()+  (MonadIO m) => Span -> IntegrationEvent -> KafkaProducerRecord -> m () setProducerAttributes sp event _record = do-    addAttribute sp (unkey messaging_system) ("kafka" :: Text)-    addAttribute sp (unkey messaging_operation_type) ("publish" :: Text)-    addAttribute sp (unkey messaging_operation_name) ("send" :: Text)-    addAttribute sp (unkey messaging_destination_name) (event ^. #destination)-    addAttribute sp (unkey messaging_message_id) (event ^. #messageId)-    case event ^. #key of-        Nothing -> pure ()-        Just k -> addAttribute sp (unkey messaging_kafka_message_key) k+  addAttribute sp (unkey messaging_system) ("kafka" :: Text)+  addAttribute sp (unkey messaging_operation_type) ("publish" :: Text)+  addAttribute sp (unkey messaging_operation_name) ("send" :: Text)+  addAttribute sp (unkey messaging_destination_name) (event ^. #destination)+  addAttribute sp (unkey messaging_message_id) (event ^. #messageId)+  case event ^. #key of+    Nothing -> pure ()+    Just k -> addAttribute sp (unkey messaging_kafka_message_key) k  setConsumerAttributes ::-    (MonadIO m) =>-    Span ->-    Maybe Text ->-    KafkaInboundRecord ->-    Maybe IntegrationEvent ->-    m ()+  (MonadIO m) =>+  Span ->+  Maybe Text ->+  KafkaInboundRecord ->+  Maybe IntegrationEvent ->+  m () setConsumerAttributes sp consumerGroup record mEvent = do-    addAttribute sp (unkey messaging_system) ("kafka" :: Text)-    addAttribute sp (unkey messaging_operation_type) ("process" :: Text)-    addAttribute sp (unkey messaging_operation_name) ("process" :: Text)-    addAttribute sp (unkey messaging_destination_name) (record ^. #topic)-    addAttribute sp (unkey messaging_destination_partition_id) (showText (record ^. #partition))-    addAttribute sp (unkey messaging_kafka_offset) (record ^. #offset)-    case record ^. #key of-        Nothing -> pure ()-        Just k -> addAttribute sp (unkey messaging_kafka_message_key) k-    case consumerGroup of-        Nothing -> pure ()-        Just g -> addAttribute sp (unkey messaging_consumer_group_name) g-    case mEvent of-        Nothing -> pure ()-        Just event -> addAttribute sp (unkey messaging_message_id) (event ^. #messageId)+  addAttribute sp (unkey messaging_system) ("kafka" :: Text)+  addAttribute sp (unkey messaging_operation_type) ("process" :: Text)+  addAttribute sp (unkey messaging_operation_name) ("process" :: Text)+  addAttribute sp (unkey messaging_destination_name) (record ^. #topic)+  addAttribute sp (unkey messaging_destination_partition_id) (showText (record ^. #partition))+  addAttribute sp (unkey messaging_kafka_offset) (record ^. #offset)+  case record ^. #key of+    Nothing -> pure ()+    Just k -> addAttribute sp (unkey messaging_kafka_message_key) k+  case consumerGroup of+    Nothing -> pure ()+    Just g -> addAttribute sp (unkey messaging_consumer_group_name) g+  case mEvent of+    Nothing -> pure ()+    Just event -> addAttribute sp (unkey messaging_message_id) (event ^. #messageId)  showText :: (Show a) => a -> Text showText = Text.pack . show@@ -518,394 +506,469 @@ -- Metrics surface -- --------------------------------------------------------------------------- -{- $metrics-Alongside the span helpers above, 'Keiro.Telemetry' exposes the library's-metrics surface: a 'KeiroMetrics' record holding every instrument keiro-records (built once from a 'Meter' by 'newKeiroMetrics'), and one-@record*@ helper per instrument that takes a @'Maybe' 'KeiroMetrics'@ and-no-ops on 'Nothing'. This mirrors the @'Maybe' 'Tracer'@ opt-in the span-helpers use: an application that never configures a 'MeterProvider' pays-only one 'Maybe' branch per recording site. The per-instrument name, unit,-kind, and description are catalogued in-@docs/research/opentelemetry-semconv-audit.md@.--}+-- $metrics+-- Alongside the span helpers above, 'Keiro.Telemetry' exposes the library's+-- metrics surface: a 'KeiroMetrics' record holding every instrument keiro+-- records (built once from a 'Meter' by 'newKeiroMetrics'), and one+-- @record*@ helper per instrument that takes a @'Maybe' 'KeiroMetrics'@ and+-- no-ops on 'Nothing'. This mirrors the @'Maybe' 'Tracer'@ opt-in the span+-- helpers use: an application that never configures a 'MeterProvider' pays+-- only one 'Maybe' branch per recording site. The per-instrument name, unit,+-- kind, and description are catalogued in+-- @docs/research/opentelemetry-semconv-audit.md@. -{- | The instrumentation scope keiro tags all its metric instruments with.-Mirrors the @"keiro"@ scope name the span helpers use on the application's-'Tracer'.--}+-- | The instrumentation scope keiro tags all its metric instruments with.+-- Mirrors the @"keiro"@ scope name the span helpers use on the application's+-- 'Tracer'. keiroInstrumentationLibrary :: InstrumentationLibrary keiroInstrumentationLibrary =-    InstrumentationLibrary-        { libraryName = "keiro"-        , libraryVersion = ""-        , librarySchemaUrl = ""-        , libraryAttributes = emptyAttributes-        }+  InstrumentationLibrary+    { libraryName = "keiro",+      libraryVersion = "",+      librarySchemaUrl = "",+      libraryAttributes = emptyAttributes+    }  keiroOutboxBacklogName :: Text keiroOutboxBacklogName = "keiro.outbox.backlog"+ keiroOutboxPublishedName :: Text keiroOutboxPublishedName = "keiro.outbox.published"+ keiroOutboxRetriedName :: Text keiroOutboxRetriedName = "keiro.outbox.retried"+ keiroOutboxDeadletteredName :: Text keiroOutboxDeadletteredName = "keiro.outbox.deadlettered"+ keiroOutboxReclaimedName :: Text keiroOutboxReclaimedName = "keiro.outbox.reclaimed"+ keiroInboxProcessedName :: Text keiroInboxProcessedName = "keiro.inbox.processed"+ keiroInboxDuplicatesName :: Text keiroInboxDuplicatesName = "keiro.inbox.duplicates"+ keiroInboxFailedName :: Text keiroInboxFailedName = "keiro.inbox.failed"+ keiroInboxPoisonedName :: Text keiroInboxPoisonedName = "keiro.inbox.poisoned"+ keiroInboxBacklogName :: Text keiroInboxBacklogName = "keiro.inbox.backlog"+ keiroTimerBacklogName :: Text keiroTimerBacklogName = "keiro.timer.backlog"+ keiroTimerFireLagName :: Text keiroTimerFireLagName = "keiro.timer.fire.lag"+ keiroTimerAttemptsName :: Text keiroTimerAttemptsName = "keiro.timer.attempts"+ keiroTimerStuckName :: Text keiroTimerStuckName = "keiro.timer.stuck"+ keiroTimerRequeuedName :: Text keiroTimerRequeuedName = "keiro.timer.requeued"+ keiroProjectionLagName :: Text keiroProjectionLagName = "keiro.projection.lag"+ keiroProjectionWaitTimeoutsName :: Text keiroProjectionWaitTimeoutsName = "keiro.projection.wait.timeouts"+ keiroCommandConflictsName :: Text keiroCommandConflictsName = "keiro.command.conflicts"+ keiroCommandRetriesName :: Text keiroCommandRetriesName = "keiro.command.retries"+ keiroCommandDuplicatesName :: Text keiroCommandDuplicatesName = "keiro.command.duplicates"+ keiroSnapshotDecodeFailuresName :: Text keiroSnapshotDecodeFailuresName = "keiro.snapshot.decode.failures"+ keiroSnapshotEncodeFailuresName :: Text keiroSnapshotEncodeFailuresName = "keiro.snapshot.encode.failures"+ keiroSnapshotReadHitsName :: Text keiroSnapshotReadHitsName = "keiro.snapshot.read.hits"+ keiroSnapshotReadMissesName :: Text keiroSnapshotReadMissesName = "keiro.snapshot.read.misses"+ keiroSnapshotWriteFailuresName :: Text keiroSnapshotWriteFailuresName = "keiro.snapshot.write.failures"+ keiroSnapshotApplyDivergenceName :: Text keiroSnapshotApplyDivergenceName = "keiro.snapshot.apply.divergence"+ keiroSnapshotSeedDivergenceName :: Text keiroSnapshotSeedDivergenceName = "keiro.snapshot.seed.divergence"+ keiroDispatchFailedName :: Text keiroDispatchFailedName = "keiro.dispatch.failed"+ keiroDispatchDeadletteredName :: Text keiroDispatchDeadletteredName = "keiro.dispatch.deadlettered"+ keiroSubscriptionDeadletteredName :: Text keiroSubscriptionDeadletteredName = "keiro.subscription.deadlettered"+ keiroDispatchDuplicatesName :: Text keiroDispatchDuplicatesName = "keiro.dispatch.duplicates"+ keiroDispatchPoisonName :: Text keiroDispatchPoisonName = "keiro.dispatch.poison"+ keiroWorkflowStepsExecutedName :: Text keiroWorkflowStepsExecutedName = "keiro.workflow.steps.executed"+ keiroWorkflowStepsReplayedName :: Text keiroWorkflowStepsReplayedName = "keiro.workflow.steps.replayed"+ keiroWorkflowResumedName :: Text keiroWorkflowResumedName = "keiro.workflow.resumed"+ keiroWorkflowFailedName :: Text keiroWorkflowFailedName = "keiro.workflow.failed"+ keiroWorkflowResumeErrorsName :: Text keiroWorkflowResumeErrorsName = "keiro.workflow.resume.errors"+ keiroWorkflowLeaseSkippedName :: Text keiroWorkflowLeaseSkippedName = "keiro.workflow.lease.skipped"+ keiroWorkflowJournalLengthName :: Text keiroWorkflowJournalLengthName = "keiro.workflow.journal.length"+ keiroWorkflowAwakeablesPendingName :: Text keiroWorkflowAwakeablesPendingName = "keiro.workflow.awakeables.pending"+ keiroWorkflowActiveName :: Text keiroWorkflowActiveName = "keiro.workflow.active" -{- | All metric instruments the keiro library records, built once from a-'Meter' by 'newKeiroMetrics'. Workers accept a @'Maybe' 'KeiroMetrics'@ and-treat 'Nothing' as "record nothing"; the per-instrument recording helpers in-this module take @'Maybe' 'KeiroMetrics'@ so call sites stay one-liners.--Instrument kinds follow the keiro metrics policy: backlog and lag are-synchronous gauges recorded by each worker per poll pass; tallies are-monotonic counters; distributions are histograms. See-@docs/research/opentelemetry-semconv-audit.md@ for the per-instrument-name / unit / kind / description catalogue.--}+-- | All metric instruments the keiro library records, built once from a+-- 'Meter' by 'newKeiroMetrics'. Workers accept a @'Maybe' 'KeiroMetrics'@ and+-- treat 'Nothing' as "record nothing"; the per-instrument recording helpers in+-- this module take @'Maybe' 'KeiroMetrics'@ so call sites stay one-liners.+--+-- Instrument kinds follow the keiro metrics policy: backlog and lag are+-- synchronous gauges recorded by each worker per poll pass; tallies are+-- monotonic counters; distributions are histograms. See+-- @docs/research/opentelemetry-semconv-audit.md@ for the per-instrument+-- name / unit / kind / description catalogue. data KeiroMetrics = KeiroMetrics-    { outboxBacklog :: Gauge Int64-    , outboxPublished :: Counter Int64-    , outboxRetried :: Counter Int64-    , outboxDeadlettered :: Counter Int64-    , outboxReclaimed :: Counter Int64-    , inboxProcessed :: Counter Int64-    , inboxDuplicates :: Counter Int64-    , inboxFailed :: Counter Int64-    , inboxPoisoned :: Counter Int64-    , inboxBacklog :: Gauge Int64-    , timerBacklog :: Gauge Int64-    , timerFireLag :: Histogram-    , timerAttempts :: Histogram-    , timerStuck :: Gauge Int64-    , timerRequeued :: Counter Int64-    , projectionLag :: Gauge Int64-    , projectionWaitTimeouts :: Counter Int64-    , commandConflicts :: Counter Int64-    , commandRetries :: Counter Int64-    , commandDuplicates :: Counter Int64-    , snapshotDecodeFailures :: Counter Int64-    , snapshotEncodeFailures :: Counter Int64-    , snapshotReadHits :: Counter Int64-    , snapshotReadMisses :: Counter Int64-    , snapshotWriteFailures :: Counter Int64-    , snapshotApplyDivergence :: Counter Int64-    , snapshotSeedDivergence :: Counter Int64-    , dispatchFailed :: Counter Int64-    , dispatchDeadlettered :: Counter Int64-    , subscriptionDeadlettered :: Counter Int64-    , dispatchDuplicates :: Counter Int64-    , dispatchPoison :: Counter Int64-    , workflowStepsExecuted :: Counter Int64-    , workflowStepsReplayed :: Counter Int64-    , workflowResumed :: Counter Int64-    , workflowFailed :: Counter Int64-    , workflowResumeErrors :: Counter Int64-    , workflowLeaseSkipped :: Counter Int64-    , workflowActive :: Gauge Int64-    , workflowJournalLength :: Histogram-    , workflowAwakeablesPending :: Gauge Int64-    }+  { outboxBacklog :: Gauge Int64,+    outboxPublished :: Counter Int64,+    outboxRetried :: Counter Int64,+    outboxDeadlettered :: Counter Int64,+    outboxReclaimed :: Counter Int64,+    inboxProcessed :: Counter Int64,+    inboxDuplicates :: Counter Int64,+    inboxFailed :: Counter Int64,+    inboxPoisoned :: Counter Int64,+    inboxBacklog :: Gauge Int64,+    timerBacklog :: Gauge Int64,+    timerFireLag :: Histogram,+    timerAttempts :: Histogram,+    timerStuck :: Gauge Int64,+    timerRequeued :: Counter Int64,+    projectionLag :: Gauge Int64,+    projectionWaitTimeouts :: Counter Int64,+    commandConflicts :: Counter Int64,+    commandRetries :: Counter Int64,+    commandDuplicates :: Counter Int64,+    snapshotDecodeFailures :: Counter Int64,+    snapshotEncodeFailures :: Counter Int64,+    snapshotReadHits :: Counter Int64,+    snapshotReadMisses :: Counter Int64,+    snapshotWriteFailures :: Counter Int64,+    snapshotApplyDivergence :: Counter Int64,+    snapshotSeedDivergence :: Counter Int64,+    dispatchFailed :: Counter Int64,+    dispatchDeadlettered :: Counter Int64,+    subscriptionDeadlettered :: Counter Int64,+    dispatchDuplicates :: Counter Int64,+    dispatchPoison :: Counter Int64,+    workflowStepsExecuted :: Counter Int64,+    workflowStepsReplayed :: Counter Int64,+    workflowResumed :: Counter Int64,+    workflowFailed :: Counter Int64,+    workflowResumeErrors :: Counter Int64,+    workflowLeaseSkipped :: Counter Int64,+    workflowActive :: Gauge Int64,+    workflowJournalLength :: Histogram,+    workflowAwakeablesPending :: Gauge Int64+  } -{- | Construct every keiro metric instrument from a 'Meter'. Call this once at-application start after building an SDK 'OpenTelemetry.Metric.Core.MeterProvider'-and obtaining a 'Meter' (e.g. @getMeter mp keiroInstrumentationLibrary@), then-thread the resulting 'KeiroMetrics' into workers as @'Just' metrics@. Under a-no-op meter every instrument is itself a no-op, so this is safe to call-unconditionally.--}+-- | Construct every keiro metric instrument from a 'Meter'. Call this once at+-- application start after building an SDK 'OpenTelemetry.Metric.Core.MeterProvider'+-- and obtaining a 'Meter' (e.g. @getMeter mp keiroInstrumentationLibrary@), then+-- thread the resulting 'KeiroMetrics' into workers as @'Just' metrics@. Under a+-- no-op meter every instrument is itself a no-op, so this is safe to call+-- unconditionally. newKeiroMetrics :: (MonadIO m) => Meter -> m KeiroMetrics newKeiroMetrics meter = liftIO $ do-    outboxBacklog' <- gaugeI64 keiroOutboxBacklogName "{event}" "Outbox rows awaiting publish."-    outboxPublished' <- counterI64 keiroOutboxPublishedName "{event}" "Outbox events successfully published."-    outboxRetried' <- counterI64 keiroOutboxRetriedName "{event}" "Outbox publish attempts that failed and will retry."-    outboxDeadlettered' <- counterI64 keiroOutboxDeadletteredName "{event}" "Outbox events parked after exhausting retries."-    outboxReclaimed' <- counterI64 keiroOutboxReclaimedName "{event}" "Outbox rows reclaimed from a crashed or stalled publisher."-    inboxProcessed' <- counterI64 keiroInboxProcessedName "{message}" "Inbox messages processed successfully."-    inboxDuplicates' <- counterI64 keiroInboxDuplicatesName "{message}" "Inbox messages skipped as duplicates."-    inboxFailed' <- counterI64 keiroInboxFailedName "{message}" "Inbox messages whose handler failed."-    inboxPoisoned' <- counterI64 keiroInboxPoisonedName "{message}" "Inbox messages dead-lettered after exhausting handler attempts."-    inboxBacklog' <- gaugeI64 keiroInboxBacklogName "{message}" "Inbox messages awaiting processing."-    timerBacklog' <- gaugeI64 keiroTimerBacklogName "{timer}" "Due timers awaiting firing."-    timerFireLag' <- histogram keiroTimerFireLagName "ms" "Delay between a timer's scheduled time and when it fired."-    timerAttempts' <- histogram keiroTimerAttemptsName "{attempt}" "Number of attempts a timer took to fire."-    timerStuck' <- gaugeI64 keiroTimerStuckName "{timer}" "Timers stuck in the Firing state past threshold."-    timerRequeued' <- counterI64 keiroTimerRequeuedName "{timer}" "Timers moved from firing back to scheduled after a stale claim."-    projectionLag' <- gaugeI64 keiroProjectionLagName "{event}" "Events between the log head and a projection's checkpoint."-    projectionWaitTimeouts' <- counterI64 keiroProjectionWaitTimeoutsName "{timeout}" "Position-wait calls that timed out before the projection caught up."-    commandConflicts' <- counterI64 keiroCommandConflictsName "{conflict}" "Optimistic-concurrency conflicts observed by command runners."-    commandRetries' <- counterI64 keiroCommandRetriesName "{retry}" "Command retry attempts started after an optimistic-concurrency conflict."-    commandDuplicates' <- counterI64 keiroCommandDuplicatesName "{event}" "Command appends rejected as duplicate deterministic event ids."-    snapshotDecodeFailures' <- counterI64 keiroSnapshotDecodeFailuresName "{failure}" "Snapshot rows whose bytes failed to decode; hydration fell back to full replay."-    snapshotEncodeFailures' <- counterI64 keiroSnapshotEncodeFailuresName "{failure}" "Post-commit snapshot encodes that failed and were swallowed."-    snapshotReadHits' <- counterI64 keiroSnapshotReadHitsName "{read}" "Snapshot lookups that yielded a usable hydration seed."-    snapshotReadMisses' <- counterI64 keiroSnapshotReadMissesName "{read}" "Snapshot lookups that fell back to full replay."-    snapshotWriteFailures' <- counterI64 keiroSnapshotWriteFailuresName "{failure}" "Post-commit snapshot writes that failed and were swallowed."-    snapshotApplyDivergence' <- counterI64 keiroSnapshotApplyDivergenceName "{failure}" "Just-appended event batches that failed to replay from the pre-command state; the stream is poisoned and its next hydration will fail."-    snapshotSeedDivergence' <- counterI64 keiroSnapshotSeedDivergenceName "{failure}" "Sampled snapshot seeds whose encoded state disagreed with a full replay through the seed version."-    dispatchFailed' <- counterI64 keiroDispatchFailedName "{command}" "Process-manager/router dispatch commands that failed."-    dispatchDeadlettered' <- counterI64 keiroDispatchDeadletteredName "{command}" "Rejected process-manager/router dispatch commands handled by dead-letter or skip policy."-    subscriptionDeadlettered' <- counterI64 keiroSubscriptionDeadletteredName "{event}" "Kiroku source events dead-lettered by an explicit disposition or retry exhaustion."-    dispatchDuplicates' <- counterI64 keiroDispatchDuplicatesName "{command}" "Process-manager/router dispatch commands skipped as duplicate deterministic event ids."-    dispatchPoison' <- counterI64 keiroDispatchPoisonName "{message}" "Process-manager/router worker messages classified as poison."-    workflowStepsExecuted' <- counterI64 keiroWorkflowStepsExecutedName "{step}" "Workflow steps that ran their action (a journal miss)."-    workflowStepsReplayed' <- counterI64 keiroWorkflowStepsReplayedName "{step}" "Workflow steps short-circuited to a recorded result (a journal hit)."-    workflowResumed' <- counterI64 keiroWorkflowResumedName "{workflow}" "Workflow re-invocations performed by the resume worker."-    workflowFailed' <- counterI64 keiroWorkflowFailedName "{workflow}" "Workflow instances marked terminally failed by the resume worker."-    workflowResumeErrors' <- counterI64 keiroWorkflowResumeErrorsName "{error}" "Transient store errors observed by the workflow resume worker."-    workflowLeaseSkipped' <- counterI64 keiroWorkflowLeaseSkippedName "{workflow}" "Workflow instances skipped because another worker owns their lease."-    workflowActive' <- gaugeI64 keiroWorkflowActiveName "{workflow}" "Workflow runs currently in progress in this process."-    workflowJournalLength' <- histogram keiroWorkflowJournalLengthName "{event}" "Journal event count of a workflow at completion."-    workflowAwakeablesPending' <- gaugeI64 keiroWorkflowAwakeablesPendingName "{awakeable}" "Awakeables awaiting an external signal."-    pure-        KeiroMetrics-            { outboxBacklog = outboxBacklog'-            , outboxPublished = outboxPublished'-            , outboxRetried = outboxRetried'-            , outboxDeadlettered = outboxDeadlettered'-            , outboxReclaimed = outboxReclaimed'-            , inboxProcessed = inboxProcessed'-            , inboxDuplicates = inboxDuplicates'-            , inboxFailed = inboxFailed'-            , inboxPoisoned = inboxPoisoned'-            , inboxBacklog = inboxBacklog'-            , timerBacklog = timerBacklog'-            , timerFireLag = timerFireLag'-            , timerAttempts = timerAttempts'-            , timerStuck = timerStuck'-            , timerRequeued = timerRequeued'-            , projectionLag = projectionLag'-            , projectionWaitTimeouts = projectionWaitTimeouts'-            , commandConflicts = commandConflicts'-            , commandRetries = commandRetries'-            , commandDuplicates = commandDuplicates'-            , snapshotDecodeFailures = snapshotDecodeFailures'-            , snapshotEncodeFailures = snapshotEncodeFailures'-            , snapshotReadHits = snapshotReadHits'-            , snapshotReadMisses = snapshotReadMisses'-            , snapshotWriteFailures = snapshotWriteFailures'-            , snapshotApplyDivergence = snapshotApplyDivergence'-            , snapshotSeedDivergence = snapshotSeedDivergence'-            , dispatchFailed = dispatchFailed'-            , dispatchDeadlettered = dispatchDeadlettered'-            , subscriptionDeadlettered = subscriptionDeadlettered'-            , dispatchDuplicates = dispatchDuplicates'-            , dispatchPoison = dispatchPoison'-            , workflowStepsExecuted = workflowStepsExecuted'-            , workflowStepsReplayed = workflowStepsReplayed'-            , workflowResumed = workflowResumed'-            , workflowFailed = workflowFailed'-            , workflowResumeErrors = workflowResumeErrors'-            , workflowLeaseSkipped = workflowLeaseSkipped'-            , workflowActive = workflowActive'-            , workflowJournalLength = workflowJournalLength'-            , workflowAwakeablesPending = workflowAwakeablesPending'-            }+  outboxBacklog' <- gaugeI64 keiroOutboxBacklogName "{event}" "Outbox rows awaiting publish."+  outboxPublished' <- counterI64 keiroOutboxPublishedName "{event}" "Outbox events successfully published."+  outboxRetried' <- counterI64 keiroOutboxRetriedName "{event}" "Outbox publish attempts that failed and will retry."+  outboxDeadlettered' <- counterI64 keiroOutboxDeadletteredName "{event}" "Outbox events parked after exhausting retries."+  outboxReclaimed' <- counterI64 keiroOutboxReclaimedName "{event}" "Outbox rows reclaimed from a crashed or stalled publisher."+  inboxProcessed' <- counterI64 keiroInboxProcessedName "{message}" "Inbox messages processed successfully."+  inboxDuplicates' <- counterI64 keiroInboxDuplicatesName "{message}" "Inbox messages skipped as duplicates."+  inboxFailed' <- counterI64 keiroInboxFailedName "{message}" "Inbox messages whose handler failed."+  inboxPoisoned' <- counterI64 keiroInboxPoisonedName "{message}" "Inbox messages dead-lettered after exhausting handler attempts."+  inboxBacklog' <- gaugeI64 keiroInboxBacklogName "{message}" "Inbox messages awaiting processing."+  timerBacklog' <- gaugeI64 keiroTimerBacklogName "{timer}" "Due timers awaiting firing."+  timerFireLag' <- histogram keiroTimerFireLagName "ms" "Delay between a timer's scheduled time and when it fired."+  timerAttempts' <- histogram keiroTimerAttemptsName "{attempt}" "Number of attempts a timer took to fire."+  timerStuck' <- gaugeI64 keiroTimerStuckName "{timer}" "Timers stuck in the Firing state past threshold."+  timerRequeued' <- counterI64 keiroTimerRequeuedName "{timer}" "Timers moved from firing back to scheduled after a stale claim."+  projectionLag' <- gaugeI64 keiroProjectionLagName "{event}" "Events between the log head and a projection's checkpoint."+  projectionWaitTimeouts' <- counterI64 keiroProjectionWaitTimeoutsName "{timeout}" "Position-wait calls that timed out before the projection caught up."+  commandConflicts' <- counterI64 keiroCommandConflictsName "{conflict}" "Optimistic-concurrency conflicts observed by command runners."+  commandRetries' <- counterI64 keiroCommandRetriesName "{retry}" "Command retry attempts started after an optimistic-concurrency conflict."+  commandDuplicates' <- counterI64 keiroCommandDuplicatesName "{event}" "Command appends rejected as duplicate deterministic event ids."+  snapshotDecodeFailures' <- counterI64 keiroSnapshotDecodeFailuresName "{failure}" "Snapshot rows whose bytes failed to decode; hydration fell back to full replay."+  snapshotEncodeFailures' <- counterI64 keiroSnapshotEncodeFailuresName "{failure}" "Post-commit snapshot encodes that failed and were swallowed."+  snapshotReadHits' <- counterI64 keiroSnapshotReadHitsName "{read}" "Snapshot lookups that yielded a usable hydration seed."+  snapshotReadMisses' <- counterI64 keiroSnapshotReadMissesName "{read}" "Snapshot lookups that fell back to full replay."+  snapshotWriteFailures' <- counterI64 keiroSnapshotWriteFailuresName "{failure}" "Post-commit snapshot writes that failed and were swallowed."+  snapshotApplyDivergence' <- counterI64 keiroSnapshotApplyDivergenceName "{failure}" "Just-appended event batches that failed to replay from the pre-command state; the stream is poisoned and its next hydration will fail."+  snapshotSeedDivergence' <- counterI64 keiroSnapshotSeedDivergenceName "{failure}" "Sampled snapshot seeds whose encoded state disagreed with a full replay through the seed version."+  dispatchFailed' <- counterI64 keiroDispatchFailedName "{command}" "Process-manager/router dispatch commands that failed."+  dispatchDeadlettered' <- counterI64 keiroDispatchDeadletteredName "{command}" "Rejected process-manager/router dispatch commands handled by dead-letter or skip policy."+  subscriptionDeadlettered' <- counterI64 keiroSubscriptionDeadletteredName "{event}" "Kiroku source events dead-lettered by an explicit disposition or retry exhaustion."+  dispatchDuplicates' <- counterI64 keiroDispatchDuplicatesName "{command}" "Process-manager/router dispatch commands skipped as duplicate deterministic event ids."+  dispatchPoison' <- counterI64 keiroDispatchPoisonName "{message}" "Process-manager/router worker messages classified as poison."+  workflowStepsExecuted' <- counterI64 keiroWorkflowStepsExecutedName "{step}" "Workflow steps that ran their action (a journal miss)."+  workflowStepsReplayed' <- counterI64 keiroWorkflowStepsReplayedName "{step}" "Workflow steps short-circuited to a recorded result (a journal hit)."+  workflowResumed' <- counterI64 keiroWorkflowResumedName "{workflow}" "Workflow re-invocations performed by the resume worker."+  workflowFailed' <- counterI64 keiroWorkflowFailedName "{workflow}" "Workflow instances marked terminally failed by the resume worker."+  workflowResumeErrors' <- counterI64 keiroWorkflowResumeErrorsName "{error}" "Transient store errors observed by the workflow resume worker."+  workflowLeaseSkipped' <- counterI64 keiroWorkflowLeaseSkippedName "{workflow}" "Workflow instances skipped because another worker owns their lease."+  workflowActive' <- gaugeI64 keiroWorkflowActiveName "{workflow}" "Workflow runs currently in progress in this process."+  workflowJournalLength' <- histogram keiroWorkflowJournalLengthName "{event}" "Journal event count of a workflow at completion."+  workflowAwakeablesPending' <- gaugeI64 keiroWorkflowAwakeablesPendingName "{awakeable}" "Awakeables awaiting an external signal."+  pure+    KeiroMetrics+      { outboxBacklog = outboxBacklog',+        outboxPublished = outboxPublished',+        outboxRetried = outboxRetried',+        outboxDeadlettered = outboxDeadlettered',+        outboxReclaimed = outboxReclaimed',+        inboxProcessed = inboxProcessed',+        inboxDuplicates = inboxDuplicates',+        inboxFailed = inboxFailed',+        inboxPoisoned = inboxPoisoned',+        inboxBacklog = inboxBacklog',+        timerBacklog = timerBacklog',+        timerFireLag = timerFireLag',+        timerAttempts = timerAttempts',+        timerStuck = timerStuck',+        timerRequeued = timerRequeued',+        projectionLag = projectionLag',+        projectionWaitTimeouts = projectionWaitTimeouts',+        commandConflicts = commandConflicts',+        commandRetries = commandRetries',+        commandDuplicates = commandDuplicates',+        snapshotDecodeFailures = snapshotDecodeFailures',+        snapshotEncodeFailures = snapshotEncodeFailures',+        snapshotReadHits = snapshotReadHits',+        snapshotReadMisses = snapshotReadMisses',+        snapshotWriteFailures = snapshotWriteFailures',+        snapshotApplyDivergence = snapshotApplyDivergence',+        snapshotSeedDivergence = snapshotSeedDivergence',+        dispatchFailed = dispatchFailed',+        dispatchDeadlettered = dispatchDeadlettered',+        subscriptionDeadlettered = subscriptionDeadlettered',+        dispatchDuplicates = dispatchDuplicates',+        dispatchPoison = dispatchPoison',+        workflowStepsExecuted = workflowStepsExecuted',+        workflowStepsReplayed = workflowStepsReplayed',+        workflowResumed = workflowResumed',+        workflowFailed = workflowFailed',+        workflowResumeErrors = workflowResumeErrors',+        workflowLeaseSkipped = workflowLeaseSkipped',+        workflowActive = workflowActive',+        workflowJournalLength = workflowJournalLength',+        workflowAwakeablesPending = workflowAwakeablesPending'+      }   where     counterI64 :: Text -> Text -> Text -> IO (Counter Int64)     counterI64 name unit desc =-        meterCreateCounterInt64 meter name (Just unit) (Just desc) defaultAdvisoryParameters+      meterCreateCounterInt64 meter name (Just unit) (Just desc) defaultAdvisoryParameters     gaugeI64 :: Text -> Text -> Text -> IO (Gauge Int64)     gaugeI64 name unit desc =-        meterCreateGaugeInt64 meter name (Just unit) (Just desc) defaultAdvisoryParameters+      meterCreateGaugeInt64 meter name (Just unit) (Just desc) defaultAdvisoryParameters     histogram :: Text -> Text -> Text -> IO Histogram     histogram name unit desc =-        meterCreateHistogram meter name (Just unit) (Just desc) defaultAdvisoryParameters+      meterCreateHistogram meter name (Just unit) (Just desc) defaultAdvisoryParameters  -- Internal: record an Int64 on the counter selected by @sel@, or do nothing. recordCounter ::-    (MonadIO m) => (KeiroMetrics -> Counter Int64) -> Maybe KeiroMetrics -> Int64 -> m ()+  (MonadIO m) => (KeiroMetrics -> Counter Int64) -> Maybe KeiroMetrics -> Int64 -> m () recordCounter _ Nothing _ = pure () recordCounter sel (Just ms) n = liftIO (counterAdd (sel ms) n emptyAttributes)  -- Internal: record an Int64 on the gauge selected by @sel@, or do nothing. recordGaugeI64 ::-    (MonadIO m) => (KeiroMetrics -> Gauge Int64) -> Maybe KeiroMetrics -> Int64 -> m ()+  (MonadIO m) => (KeiroMetrics -> Gauge Int64) -> Maybe KeiroMetrics -> Int64 -> m () recordGaugeI64 _ Nothing _ = pure () recordGaugeI64 sel (Just ms) n = liftIO (gaugeRecord (sel ms) n emptyAttributes)  -- Internal: record a Double on the histogram selected by @sel@, or do nothing. recordHistogram ::-    (MonadIO m) => (KeiroMetrics -> Histogram) -> Maybe KeiroMetrics -> Double -> m ()+  (MonadIO m) => (KeiroMetrics -> Histogram) -> Maybe KeiroMetrics -> Double -> m () recordHistogram _ Nothing _ = pure () recordHistogram sel (Just ms) v = liftIO (histogramRecord (sel ms) v emptyAttributes)  recordOutboxBacklog :: (MonadIO m) => Maybe KeiroMetrics -> Int64 -> m () recordOutboxBacklog = recordGaugeI64 outboxBacklog+ recordOutboxPublished :: (MonadIO m) => Maybe KeiroMetrics -> Int64 -> m () recordOutboxPublished = recordCounter outboxPublished+ recordOutboxRetried :: (MonadIO m) => Maybe KeiroMetrics -> Int64 -> m () recordOutboxRetried = recordCounter outboxRetried+ recordOutboxDeadlettered :: (MonadIO m) => Maybe KeiroMetrics -> Int64 -> m () recordOutboxDeadlettered = recordCounter outboxDeadlettered+ recordOutboxReclaimed :: (MonadIO m) => Maybe KeiroMetrics -> Int64 -> m () recordOutboxReclaimed = recordCounter outboxReclaimed+ recordInboxProcessed :: (MonadIO m) => Maybe KeiroMetrics -> Int64 -> m () recordInboxProcessed = recordCounter inboxProcessed+ recordInboxDuplicates :: (MonadIO m) => Maybe KeiroMetrics -> Int64 -> m () recordInboxDuplicates = recordCounter inboxDuplicates+ recordInboxFailed :: (MonadIO m) => Maybe KeiroMetrics -> Int64 -> m () recordInboxFailed = recordCounter inboxFailed+ recordInboxPoisoned :: (MonadIO m) => Maybe KeiroMetrics -> Int64 -> m () recordInboxPoisoned = recordCounter inboxPoisoned+ recordInboxBacklog :: (MonadIO m) => Maybe KeiroMetrics -> Int64 -> m () recordInboxBacklog = recordGaugeI64 inboxBacklog+ recordTimerBacklog :: (MonadIO m) => Maybe KeiroMetrics -> Int64 -> m () recordTimerBacklog = recordGaugeI64 timerBacklog+ recordTimerFireLag :: (MonadIO m) => Maybe KeiroMetrics -> Double -> m () recordTimerFireLag = recordHistogram timerFireLag+ recordTimerAttempts :: (MonadIO m) => Maybe KeiroMetrics -> Double -> m () recordTimerAttempts = recordHistogram timerAttempts+ recordTimerStuck :: (MonadIO m) => Maybe KeiroMetrics -> Int64 -> m () recordTimerStuck = recordGaugeI64 timerStuck+ recordTimerRequeued :: (MonadIO m) => Maybe KeiroMetrics -> Int64 -> m () recordTimerRequeued = recordCounter timerRequeued+ recordProjectionLag :: (MonadIO m) => Maybe KeiroMetrics -> Int64 -> m () recordProjectionLag = recordGaugeI64 projectionLag+ recordProjectionWaitTimeouts :: (MonadIO m) => Maybe KeiroMetrics -> Int64 -> m () recordProjectionWaitTimeouts = recordCounter projectionWaitTimeouts+ recordCommandConflicts :: (MonadIO m) => Maybe KeiroMetrics -> Int64 -> m () recordCommandConflicts = recordCounter commandConflicts+ recordCommandRetries :: (MonadIO m) => Maybe KeiroMetrics -> Int64 -> m () recordCommandRetries = recordCounter commandRetries+ recordCommandDuplicates :: (MonadIO m) => Maybe KeiroMetrics -> Int64 -> m () recordCommandDuplicates = recordCounter commandDuplicates+ recordSnapshotDecodeFailures :: (MonadIO m) => Maybe KeiroMetrics -> Int64 -> m () recordSnapshotDecodeFailures = recordCounter snapshotDecodeFailures+ recordSnapshotEncodeFailures :: (MonadIO m) => Maybe KeiroMetrics -> Int64 -> m () recordSnapshotEncodeFailures = recordCounter snapshotEncodeFailures+ recordSnapshotReadHits :: (MonadIO m) => Maybe KeiroMetrics -> Int64 -> m () recordSnapshotReadHits = recordCounter snapshotReadHits+ recordSnapshotReadMisses :: (MonadIO m) => Maybe KeiroMetrics -> Int64 -> m () recordSnapshotReadMisses = recordCounter snapshotReadMisses+ recordSnapshotWriteFailures :: (MonadIO m) => Maybe KeiroMetrics -> Int64 -> m () recordSnapshotWriteFailures = recordCounter snapshotWriteFailures+ recordSnapshotApplyDivergence :: (MonadIO m) => Maybe KeiroMetrics -> Int64 -> m () recordSnapshotApplyDivergence = recordCounter snapshotApplyDivergence+ recordSnapshotSeedDivergence :: (MonadIO m) => Maybe KeiroMetrics -> Int64 -> m () recordSnapshotSeedDivergence = recordCounter snapshotSeedDivergence+ recordDispatchFailed :: (MonadIO m) => Maybe KeiroMetrics -> Int64 -> m () recordDispatchFailed = recordCounter dispatchFailed+ recordDispatchDeadLettered :: (MonadIO m) => Maybe KeiroMetrics -> Int64 -> m () recordDispatchDeadLettered = recordCounter dispatchDeadlettered+ recordSubscriptionDeadLettered :: (MonadIO m) => Maybe KeiroMetrics -> Int64 -> m () recordSubscriptionDeadLettered = recordCounter subscriptionDeadlettered+ recordDispatchDuplicate :: (MonadIO m) => Maybe KeiroMetrics -> Int64 -> m () recordDispatchDuplicate = recordCounter dispatchDuplicates+ recordDispatchPoison :: (MonadIO m) => Maybe KeiroMetrics -> Int64 -> m () recordDispatchPoison = recordCounter dispatchPoison+ recordWorkflowStepExecuted :: (MonadIO m) => Maybe KeiroMetrics -> Int64 -> m () recordWorkflowStepExecuted = recordCounter workflowStepsExecuted+ recordWorkflowStepReplayed :: (MonadIO m) => Maybe KeiroMetrics -> Int64 -> m () recordWorkflowStepReplayed = recordCounter workflowStepsReplayed+ recordWorkflowResumed :: (MonadIO m) => Maybe KeiroMetrics -> Int64 -> m () recordWorkflowResumed = recordCounter workflowResumed+ recordWorkflowFailed :: (MonadIO m) => Maybe KeiroMetrics -> Int64 -> m () recordWorkflowFailed = recordCounter workflowFailed+ recordWorkflowResumeErrors :: (MonadIO m) => Maybe KeiroMetrics -> Int64 -> m () recordWorkflowResumeErrors = recordCounter workflowResumeErrors+ recordWorkflowLeaseSkipped :: (MonadIO m) => Maybe KeiroMetrics -> Int64 -> m () recordWorkflowLeaseSkipped = recordCounter workflowLeaseSkipped+ recordWorkflowActive :: (MonadIO m) => Maybe KeiroMetrics -> Int64 -> m () recordWorkflowActive = recordGaugeI64 workflowActive+ recordWorkflowJournalLength :: (MonadIO m) => Maybe KeiroMetrics -> Double -> m () recordWorkflowJournalLength = recordHistogram workflowJournalLength+ recordWorkflowAwakeablesPending :: (MonadIO m) => Maybe KeiroMetrics -> Int64 -> m () recordWorkflowAwakeablesPending = recordGaugeI64 workflowAwakeablesPending -{- | Feed Kiroku store events into Keiro metrics, then delegate every event to-the application's existing event handler. Install this as (or inside) the-@eventHandler@ on Kiroku's @ConnectionSettings@ at store construction; pass-@const (pure ())@ when there is no other handler.--'KirokuEventSubscriptionDeadLettered' is the terminal retry-exhaustion signal:-the acknowledgement bridge exposes the current delivery attempt, but does not-tell a handler that its retry reply consumed the final attempt. For current-dead-letter depth, query Kiroku's durable table rather than treating this-monotonic counter as a gauge:--> SELECT count(*) FROM kiroku.dead_letters WHERE subscription_name = $1--The delegate runs synchronously, matching Kiroku's event-handler contract, so-it should remain fast and non-blocking.--}+-- | Feed Kiroku store events into Keiro metrics, then delegate every event to+-- the application's existing event handler. Install this as (or inside) the+-- @eventHandler@ on Kiroku's @ConnectionSettings@ at store construction; pass+-- @const (pure ())@ when there is no other handler.+--+-- 'KirokuEventSubscriptionDeadLettered' is the terminal retry-exhaustion signal:+-- the acknowledgement bridge exposes the current delivery attempt, but does not+-- tell a handler that its retry reply consumed the final attempt. For current+-- dead-letter depth, query Kiroku's durable table rather than treating this+-- monotonic counter as a gauge:+--+-- > SELECT count(*) FROM kiroku.dead_letters WHERE subscription_name = $1+--+-- The delegate runs synchronously, matching Kiroku's event-handler contract, so+-- it should remain fast and non-blocking. kirokuEventBridge :: Maybe KeiroMetrics -> (KirokuEvent -> IO ()) -> KirokuEvent -> IO () kirokuEventBridge metrics delegate event = do-    case event of-        KirokuEventSubscriptionDeadLettered{} -> recordSubscriptionDeadLettered metrics 1-        _ -> pure ()-    delegate event+  case event of+    KirokuEventSubscriptionDeadLettered {} -> recordSubscriptionDeadLettered metrics 1+    _ -> pure ()+  delegate event
src/Keiro/Timer.hs view
@@ -1,20 +1,19 @@-{- | Durable timers for process managers.--A process manager schedules a timer ('scheduleTimerTx', in its own append-transaction) to be woken at a future time — a saga timeout, a retry delay, a-deadline. The 'runTimerWorker' loop claims one due timer at a time with-@FOR UPDATE SKIP LOCKED@ (so multiple workers can run safely), hands it to a-caller-supplied @fire@ action that typically dispatches a command back into-the manager, and marks it fired once the resulting event id is known. A-timer left @Firing@ by a crash becomes claimable again after the worker's-configured stale-claim timeout, giving at-least-once firing.--The wire types live in "Keiro.Timer.Types" and the SQL storage in-"Keiro.Timer.Schema"; both are re-exported here so most callers need only-import @Keiro.Timer@.--}-module Keiro.Timer (-    -- * Timer types+-- | Durable timers for process managers.+--+-- A process manager schedules a timer ('scheduleTimerTx', in its own append+-- transaction) to be woken at a future time — a saga timeout, a retry delay, a+-- deadline. The 'runTimerWorker' loop claims one due timer at a time with+-- @FOR UPDATE SKIP LOCKED@ (so multiple workers can run safely), hands it to a+-- caller-supplied @fire@ action that typically dispatches a command back into+-- the manager, and marks it fired once the resulting event id is known. A+-- timer left @Firing@ by a crash becomes claimable again after the worker's+-- configured stale-claim timeout, giving at-least-once firing.+--+-- The wire types live in "Keiro.Timer.Types" and the SQL storage in+-- "Keiro.Timer.Schema"; both are re-exported here so most callers need only+-- import @Keiro.Timer@.+module Keiro.Timer+  ( -- * Timer types     TimerId (..),     TimerRequest (..),     TimerRow (..),@@ -44,21 +43,21 @@     mkTimerWorkerOptions,     runTimerWorker,     runTimerWorkerWith,-)+  ) where  import Data.Text qualified as Text import Data.Time.Clock (NominalDiffTime, diffUTCTime) import Effectful (Eff, IOE, (:>)) import Keiro.Prelude-import Keiro.Telemetry (-    KeiroMetrics,+import Keiro.Telemetry+  ( KeiroMetrics,     recordTimerAttempts,     recordTimerBacklog,     recordTimerFireLag,     recordTimerRequeued,     recordTimerStuck,- )+  ) import Keiro.Timer.Schema import Keiro.Timer.Types import Kiroku.Store.Effect (Store)@@ -66,114 +65,110 @@  -- | Options controlling 'runTimerWorkerWith'. data TimerWorkerOptions = TimerWorkerOptions-    { maxAttempts :: Maybe Int-    {- ^ When @Just n@, a claimed timer whose post-claim @attempts@ exceeds @n@ is-    moved to 'Dead' (via 'deadLetterTimer') instead of being fired. @Nothing@-    never auto-dead-letters (the historical behavior).-    -}-    , requeueStuckAfter :: !(Maybe NominalDiffTime)-    {- ^ When @Just ttl@, each worker pass first moves @Firing@ timers whose-    @updated_at@ is at least @ttl@ old back to 'Scheduled'. A fire action that-    runs longer than this timeout may be fired again; timer handlers must be-    idempotent under keiro's at-least-once timer contract. @Nothing@ disables-    automatic requeue for callers that run their own recovery.-    -}-    }-    deriving stock (Generic, Eq, Show)+  { -- | When @Just n@, a claimed timer whose post-claim @attempts@ exceeds @n@ is+    --     moved to 'Dead' (via 'deadLetterTimer') instead of being fired. @Nothing@+    --     never auto-dead-letters (the historical behavior).+    maxAttempts :: Maybe Int,+    -- | When @Just ttl@, each worker pass first moves @Firing@ timers whose+    --     @updated_at@ is at least @ttl@ old back to 'Scheduled'. A fire action that+    --     runs longer than this timeout may be fired again; timer handlers must be+    --     idempotent under keiro's at-least-once timer contract. @Nothing@ disables+    --     automatic requeue for callers that run their own recovery.+    requeueStuckAfter :: !(Maybe NominalDiffTime)+  }+  deriving stock (Generic, Eq, Show)  data TimerWorkerConfigError-    = InvalidTimerMaxAttempts !Int-    | InvalidTimerRequeueStuckAfter !NominalDiffTime-    deriving stock (Generic, Eq, Show)+  = InvalidTimerMaxAttempts !Int+  | InvalidTimerRequeueStuckAfter !NominalDiffTime+  deriving stock (Generic, Eq, Show)  -- | The default worker policy: never auto-dead-letter; requeue stale firings after five minutes. defaultTimerWorkerOptions :: TimerWorkerOptions-defaultTimerWorkerOptions = TimerWorkerOptions{maxAttempts = Nothing, requeueStuckAfter = Just 300}+defaultTimerWorkerOptions = TimerWorkerOptions {maxAttempts = Nothing, requeueStuckAfter = Just 300}  -- | Validate timer worker options before starting a worker loop. mkTimerWorkerOptions :: TimerWorkerOptions -> Either TimerWorkerConfigError TimerWorkerOptions mkTimerWorkerOptions opts =-    case (opts ^. #maxAttempts, opts ^. #requeueStuckAfter) of-        (Just attempts, _) | attempts < 0 -> Left (InvalidTimerMaxAttempts attempts)-        (_, Just ttl) | ttl <= 0 -> Left (InvalidTimerRequeueStuckAfter ttl)-        _ -> Right opts--{- | Claim and fire at most one timer due at @now@, applying the given-'TimerWorkerOptions'.--Atomically claims the earliest due timer (marking it @Firing@). If the options-set @maxAttempts = Just n@ and the timer's post-claim @attempts@ exceeds @n@, it-is dead-lettered ('Dead', with an explanatory @last_error@) instead of fired —-rather than ping-ponging forever on a timer that never completes. Before-claiming, the worker requeues stale @Firing@ rows according to-'requeueStuckAfter'. Otherwise the caller's @fire@ action runs and — if it-returns the id of the event it produced — the timer is marked @Fired@. Returns-the claimed 'TimerRow' (the row as claimed, before any dead-letter or fire-UPDATE), or 'Nothing' when nothing is due. A @fire@ that returns 'Nothing'-leaves the timer @Firing@ until it becomes stale and is requeued on a later-worker pass.--A timer may fire more than once if a worker crashes after the external action-but before 'markTimerFired', or if @fire@ takes longer than 'requeueStuckAfter'.-Handlers must therefore be idempotent.+  case (opts ^. #maxAttempts, opts ^. #requeueStuckAfter) of+    (Just attempts, _) | attempts < 0 -> Left (InvalidTimerMaxAttempts attempts)+    (_, Just ttl) | ttl <= 0 -> Left (InvalidTimerRequeueStuckAfter ttl)+    _ -> Right opts -Note 'claimDueTimer' increments @attempts@ before this check, so the comparison-sees the post-claim count: with @maxAttempts = Just 0@ the very first claim-dead-letters; with @Just 2@ the third claim does.--}+-- | Claim and fire at most one timer due at @now@, applying the given+-- 'TimerWorkerOptions'.+--+-- Atomically claims the earliest due timer (marking it @Firing@). If the options+-- set @maxAttempts = Just n@ and the timer's post-claim @attempts@ exceeds @n@, it+-- is dead-lettered ('Dead', with an explanatory @last_error@) instead of fired —+-- rather than ping-ponging forever on a timer that never completes. Before+-- claiming, the worker requeues stale @Firing@ rows according to+-- 'requeueStuckAfter'. Otherwise the caller's @fire@ action runs and — if it+-- returns the id of the event it produced — the timer is marked @Fired@. Returns+-- the claimed 'TimerRow' (the row as claimed, before any dead-letter or fire+-- UPDATE), or 'Nothing' when nothing is due. A @fire@ that returns 'Nothing'+-- leaves the timer @Firing@ until it becomes stale and is requeued on a later+-- worker pass.+--+-- A timer may fire more than once if a worker crashes after the external action+-- but before 'markTimerFired', or if @fire@ takes longer than 'requeueStuckAfter'.+-- Handlers must therefore be idempotent.+--+-- Note 'claimDueTimer' increments @attempts@ before this check, so the comparison+-- sees the post-claim count: with @maxAttempts = Just 0@ the very first claim+-- dead-letters; with @Just 2@ the third claim does. runTimerWorkerWith ::-    (IOE :> es, Store :> es) =>-    Maybe KeiroMetrics ->-    TimerWorkerOptions ->-    UTCTime ->-    (TimerRow -> Eff es (Maybe EventId)) ->-    Eff es (Maybe TimerRow)+  (IOE :> es, Store :> es) =>+  Maybe KeiroMetrics ->+  TimerWorkerOptions ->+  UTCTime ->+  (TimerRow -> Eff es (Maybe EventId)) ->+  Eff es (Maybe TimerRow) runTimerWorkerWith metrics options now fire = do-    for_ (options ^. #requeueStuckAfter) $ \ttl -> do-        requeued <- requeueStuckTimers ttl now-        recordTimerRequeued metrics (fromIntegral requeued)-    -- Gauges recorded once per pass, before the claim, off the counts the worker-    -- already needs its 'Store' for: the backlog as the worker sees it at the-    -- start of the pass (including the row it is about to claim), and the number-    -- of rows stranded in 'Firing' by earlier passes that never completed. Each-    -- is a no-op under a 'Nothing' handle.-    backlog <- countDueTimers now-    recordTimerBacklog metrics (fromIntegral backlog)-    stuck <- countStuckTimers now anyStuckTimer-    recordTimerStuck metrics (fromIntegral stuck)-    due <- claimDueTimer now-    case due of-        Nothing -> pure Nothing-        Just timer -> do-            -- Histograms for the claimed timer: how late it fired and how many-            -- attempts it has now taken. EP-33 declared 'keiro.timer.fire.lag' in-            -- milliseconds, so the seconds 'diffUTCTime' yields are scaled by 1000.-            -- The lag is non-negative because only fire_at <= now rows are claimable.-            recordTimerFireLag metrics (realToFrac (now `diffUTCTime` (timer ^. #fireAt)) * 1000)-            recordTimerAttempts metrics (fromIntegral (timer ^. #attempts))-            case options ^. #maxAttempts of-                Just attemptCeiling-                    | (timer ^. #attempts) > attemptCeiling -> do-                        _ <--                            deadLetterTimer-                                (timer ^. #timerId)-                                ("timer exceeded attempt ceiling of " <> Text.pack (show attemptCeiling))-                        pure (Just timer)-                _ -> do-                    fired <- fire timer-                    for_ fired (\eventId -> void (markTimerFired (timer ^. #timerId) eventId))-                    pure (Just timer)+  for_ (options ^. #requeueStuckAfter) $ \ttl -> do+    requeued <- requeueStuckTimers ttl now+    recordTimerRequeued metrics (fromIntegral requeued)+  -- Gauges recorded once per pass, before the claim, off the counts the worker+  -- already needs its 'Store' for: the backlog as the worker sees it at the+  -- start of the pass (including the row it is about to claim), and the number+  -- of rows stranded in 'Firing' by earlier passes that never completed. Each+  -- is a no-op under a 'Nothing' handle.+  backlog <- countDueTimers now+  recordTimerBacklog metrics (fromIntegral backlog)+  stuck <- countStuckTimers now anyStuckTimer+  recordTimerStuck metrics (fromIntegral stuck)+  due <- claimDueTimer now+  case due of+    Nothing -> pure Nothing+    Just timer -> do+      -- Histograms for the claimed timer: how late it fired and how many+      -- attempts it has now taken. EP-33 declared 'keiro.timer.fire.lag' in+      -- milliseconds, so the seconds 'diffUTCTime' yields are scaled by 1000.+      -- The lag is non-negative because only fire_at <= now rows are claimable.+      recordTimerFireLag metrics (realToFrac (now `diffUTCTime` (timer ^. #fireAt)) * 1000)+      recordTimerAttempts metrics (fromIntegral (timer ^. #attempts))+      case options ^. #maxAttempts of+        Just attemptCeiling+          | (timer ^. #attempts) > attemptCeiling -> do+              _ <-+                deadLetterTimer+                  (timer ^. #timerId)+                  ("timer exceeded attempt ceiling of " <> Text.pack (show attemptCeiling))+              pure (Just timer)+        _ -> do+          fired <- fire timer+          for_ fired (\eventId -> void (markTimerFired (timer ^. #timerId) eventId))+          pure (Just timer) -{- | Claim and fire at most one timer due at @now@ using-'defaultTimerWorkerOptions' (no attempt ceiling). Equivalent to-@'runTimerWorkerWith' 'defaultTimerWorkerOptions'@; the default has no attempt-ceiling and requeues claims left @Firing@ for five minutes. See-'runTimerWorkerWith' for the full semantics.--}+-- | Claim and fire at most one timer due at @now@ using+-- 'defaultTimerWorkerOptions' (no attempt ceiling). Equivalent to+-- @'runTimerWorkerWith' 'defaultTimerWorkerOptions'@; the default has no attempt+-- ceiling and requeues claims left @Firing@ for five minutes. See+-- 'runTimerWorkerWith' for the full semantics. runTimerWorker ::-    (IOE :> es, Store :> es) =>-    Maybe KeiroMetrics ->-    UTCTime ->-    (TimerRow -> Eff es (Maybe EventId)) ->-    Eff es (Maybe TimerRow)+  (IOE :> es, Store :> es) =>+  Maybe KeiroMetrics ->+  UTCTime ->+  (TimerRow -> Eff es (Maybe EventId)) ->+  Eff es (Maybe TimerRow) runTimerWorker metrics = runTimerWorkerWith metrics defaultTimerWorkerOptions
src/Keiro/Timer/Schema.hs view
@@ -1,18 +1,17 @@-{- | The @keiro_timers@ table: storage and claim logic for durable timers.--Holds one row per scheduled timer with its 'TimerStatus' lifecycle.-'scheduleTimerTx' inserts (or re-arms a still-@Scheduled@ timer with the same-id) inside the caller's transaction; 'claimDueTimer' atomically picks the-single earliest due timer with @FOR UPDATE SKIP LOCKED@ and moves it to-@Firing@, so competing workers never claim the same timer; 'markTimerFired'-records completion and the produced event id. Stale @Firing@ rows are requeued-by 'requeueStuckTimers' so a crashed worker does not strand a timer forever.--Callers normally use the re-exports from "Keiro.Timer" rather than this-module directly.--}-module Keiro.Timer.Schema (-    -- * Rows and status+-- | The @keiro_timers@ table: storage and claim logic for durable timers.+--+-- Holds one row per scheduled timer with its 'TimerStatus' lifecycle.+-- 'scheduleTimerTx' inserts (or re-arms a still-@Scheduled@ timer with the same+-- id) inside the caller's transaction; 'claimDueTimer' atomically picks the+-- single earliest due timer with @FOR UPDATE SKIP LOCKED@ and moves it to+-- @Firing@, so competing workers never claim the same timer; 'markTimerFired'+-- records completion and the produced event id. Stale @Firing@ rows are requeued+-- by 'requeueStuckTimers' so a crashed worker does not strand a timer forever.+--+-- Callers normally use the re-exports from "Keiro.Timer" rather than this+-- module directly.+module Keiro.Timer.Schema+  ( -- * Rows and status     TimerStatus (..),     TimerRow (..), @@ -34,7 +33,7 @@     requeueStuckTimer,     cancelTimer,     deadLetterTimer,-)+  ) where  import Contravariant.Extras (contrazip2, contrazip6)@@ -51,405 +50,391 @@ import Kiroku.Store.Types (EventId (..)) import "hasql-transaction" Hasql.Transaction qualified as Tx -{- | A timer's lifecycle state.--* 'Scheduled' — waiting for its 'fireAt'; claimable.-* 'Firing' — claimed by a worker and being processed; stale rows become-  claimable again when 'requeueStuckTimers' moves them back to 'Scheduled'.-* 'Fired' — successfully fired; terminal.-* 'Cancelled' — withdrawn before firing.-* 'Dead' — abandoned after exceeding the attempt ceiling; terminal; carries an-  optional @last_error@ describing why it was given up on.--}+-- | A timer's lifecycle state.+--+-- * 'Scheduled' — waiting for its 'fireAt'; claimable.+-- * 'Firing' — claimed by a worker and being processed; stale rows become+--   claimable again when 'requeueStuckTimers' moves them back to 'Scheduled'.+-- * 'Fired' — successfully fired; terminal.+-- * 'Cancelled' — withdrawn before firing.+-- * 'Dead' — abandoned after exceeding the attempt ceiling; terminal; carries an+--   optional @last_error@ describing why it was given up on. data TimerStatus-    = Scheduled-    | Firing-    | Fired-    | Cancelled-    | Dead-    deriving stock (Generic, Eq, Show)+  = Scheduled+  | Firing+  | Fired+  | Cancelled+  | Dead+  deriving stock (Generic, Eq, Show) -{- | A timer row as stored: the original 'TimerRequest' fields plus the live-'status', the 'attempts' count (incremented on each claim), and the-'firedEventId' recorded once it fires.--}+-- | A timer row as stored: the original 'TimerRequest' fields plus the live+-- 'status', the 'attempts' count (incremented on each claim), and the+-- 'firedEventId' recorded once it fires. data TimerRow = TimerRow-    { timerId :: !TimerId-    , processManagerName :: !Text-    , correlationId :: !Text-    , fireAt :: !UTCTime-    , payload :: !Value-    , status :: !TimerStatus-    , attempts :: !Int-    , firedEventId :: !(Maybe EventId)-    }-    deriving stock (Generic, Eq, Show)+  { timerId :: !TimerId,+    processManagerName :: !Text,+    correlationId :: !Text,+    fireAt :: !UTCTime,+    payload :: !Value,+    status :: !TimerStatus,+    attempts :: !Int,+    firedEventId :: !(Maybe EventId)+  }+  deriving stock (Generic, Eq, Show) -{- | Criteria selecting timers stranded in 'Firing'. A row is "stuck" when its-'status' is @firing@ and it matches every set bound: 'minAge' (it has been-firing at least this long, measured from @updated_at@) and 'minAttempts' (it-has been claimed at least this many times). Both unset selects every @firing@-row.--}+-- | Criteria selecting timers stranded in 'Firing'. A row is "stuck" when its+-- 'status' is @firing@ and it matches every set bound: 'minAge' (it has been+-- firing at least this long, measured from @updated_at@) and 'minAttempts' (it+-- has been claimed at least this many times). Both unset selects every @firing@+-- row. data StuckTimerFilter = StuckTimerFilter-    { minAge :: !(Maybe NominalDiffTime)-    , minAttempts :: !(Maybe Int)-    }-    deriving stock (Generic, Eq, Show)+  { minAge :: !(Maybe NominalDiffTime),+    minAttempts :: !(Maybe Int)+  }+  deriving stock (Generic, Eq, Show)  -- | Select every @firing@ row regardless of age or attempts. anyStuckTimer :: StuckTimerFilter anyStuckTimer = StuckTimerFilter Nothing Nothing -{- | Schedule a timer inside the caller's transaction (typically a process-manager's append). Upserts on 'timerId': a conflicting row is re-armed only-while it is still @Scheduled@, so a timer that has already fired or been-cancelled is not resurrected.--}+-- | Schedule a timer inside the caller's transaction (typically a process+-- manager's append). Upserts on 'timerId': a conflicting row is re-armed only+-- while it is still @Scheduled@, so a timer that has already fired or been+-- cancelled is not resurrected. scheduleTimerTx :: TimerRequest -> Tx.Transaction () scheduleTimerTx request =-    Tx.statement-        ( timerIdToUuid (request ^. #timerId)-        , request ^. #processManagerName-        , request ^. #correlationId-        , request ^. #fireAt-        , request ^. #payload-        , statusToText Scheduled-        )-        scheduleTimerStmt--{- | Schedule a timer only if no row with the same 'timerId' already exists.+  Tx.statement+    ( timerIdToUuid (request ^. #timerId),+      request ^. #processManagerName,+      request ^. #correlationId,+      request ^. #fireAt,+      request ^. #payload,+      statusToText Scheduled+    )+    scheduleTimerStmt -This is for callers whose first arm must win, such as durable workflow sleeps:-every resume pass re-runs the sleep arm until the timer fires, and preserving-the original 'fireAt' keeps the sleep measured from the first arm. Process-managers that intentionally push a deadline back should keep using-'scheduleTimerTx'. Returns 'True' when this call inserted the row and 'False'-when an existing timer won.--}+-- | Schedule a timer only if no row with the same 'timerId' already exists.+--+-- This is for callers whose first arm must win, such as durable workflow sleeps:+-- every resume pass re-runs the sleep arm until the timer fires, and preserving+-- the original 'fireAt' keeps the sleep measured from the first arm. Process+-- managers that intentionally push a deadline back should keep using+-- 'scheduleTimerTx'. Returns 'True' when this call inserted the row and 'False'+-- when an existing timer won. scheduleTimerOnceTx :: TimerRequest -> Tx.Transaction Bool scheduleTimerOnceTx request =-    Tx.statement-        ( timerIdToUuid (request ^. #timerId)-        , request ^. #processManagerName-        , request ^. #correlationId-        , request ^. #fireAt-        , request ^. #payload-        , statusToText Scheduled-        )-        scheduleTimerOnceStmt+  Tx.statement+    ( timerIdToUuid (request ^. #timerId),+      request ^. #processManagerName,+      request ^. #correlationId,+      request ^. #fireAt,+      request ^. #payload,+      statusToText Scheduled+    )+    scheduleTimerOnceStmt -{- | Atomically claim the single earliest timer due at @now@, moving it to-@Firing@ and bumping its attempt count. Uses @FOR UPDATE SKIP LOCKED@ so-concurrent workers each get a distinct timer. Returns 'Nothing' when none is-due.--}+-- | Atomically claim the single earliest timer due at @now@, moving it to+-- @Firing@ and bumping its attempt count. Uses @FOR UPDATE SKIP LOCKED@ so+-- concurrent workers each get a distinct timer. Returns 'Nothing' when none is+-- due. claimDueTimer :: (Store :> es) => UTCTime -> Eff es (Maybe TimerRow) claimDueTimer now =-    runTransaction $-        Tx.statement now claimDueTimerStmt+  runTransaction $+    Tx.statement now claimDueTimerStmt -{- | Mark a claimed timer @Fired@, recording the id of the event its firing-produced. Returns 'False' when the row left @Firing@ while the fire action was-running (for example, it was requeued, cancelled, or dead-lettered).--}+-- | Mark a claimed timer @Fired@, recording the id of the event its firing+-- produced. Returns 'False' when the row left @Firing@ while the fire action was+-- running (for example, it was requeued, cancelled, or dead-lettered). markTimerFired :: (Store :> es) => TimerId -> EventId -> Eff es Bool markTimerFired timerId eventId =-    runTransaction $-        Tx.statement (timerIdToUuid timerId, eventIdToUuid eventId) markTimerFiredStmt+  runTransaction $+    Tx.statement (timerIdToUuid timerId, eventIdToUuid eventId) markTimerFiredStmt -{- | Count timers that are @scheduled@ and already due at @now@ — the timer-backlog. Read-only; mirrors 'claimDueTimer''s WHERE clause but counts rather-than locking, so it never claims or mutates a row.--}+-- | Count timers that are @scheduled@ and already due at @now@ — the timer+-- backlog. Read-only; mirrors 'claimDueTimer''s WHERE clause but counts rather+-- than locking, so it never claims or mutates a row. countDueTimers :: (Store :> es) => UTCTime -> Eff es Int countDueTimers now =-    runTransaction $-        Tx.statement now countDueTimersStmt+  runTransaction $+    Tx.statement now countDueTimersStmt -{- | Count timers stranded in @Firing@ that match the given 'StuckTimerFilter' —-the same "stuck" predicate 'findStuckTimers' lists, evaluated against @now@.-Read-only. 'anyStuckTimer' counts every @firing@ row.--}+-- | Count timers stranded in @Firing@ that match the given 'StuckTimerFilter' —+-- the same "stuck" predicate 'findStuckTimers' lists, evaluated against @now@.+-- Read-only. 'anyStuckTimer' counts every @firing@ row. countStuckTimers :: (Store :> es) => UTCTime -> StuckTimerFilter -> Eff es Int countStuckTimers now stuckFilter =-    runTransaction $-        Tx.statement (cutoff, fmap fromIntegral (stuckFilter ^. #minAttempts)) countStuckTimersStmt+  runTransaction $+    Tx.statement (cutoff, fmap fromIntegral (stuckFilter ^. #minAttempts)) countStuckTimersStmt   where     cutoff = fmap (\age -> addUTCTime (negate age) now) (stuckFilter ^. #minAge) -{- | List timers stranded in @Firing@ that match the given 'StuckTimerFilter'.-The @minAge@ bound is evaluated against @now@: a row qualifies when its-@updated_at@ is at least @minAge@ in the past (cutoff @now - minAge@). Results-are ordered oldest-first by @updated_at@.--}+-- | List timers stranded in @Firing@ that match the given 'StuckTimerFilter'.+-- The @minAge@ bound is evaluated against @now@: a row qualifies when its+-- @updated_at@ is at least @minAge@ in the past (cutoff @now - minAge@). Results+-- are ordered oldest-first by @updated_at@. findStuckTimers ::-    (Store :> es) => UTCTime -> StuckTimerFilter -> Eff es [TimerRow]+  (Store :> es) => UTCTime -> StuckTimerFilter -> Eff es [TimerRow] findStuckTimers now stuckFilter =-    runTransaction $-        Tx.statement (cutoff, fmap fromIntegral (stuckFilter ^. #minAttempts)) findStuckTimersStmt+  runTransaction $+    Tx.statement (cutoff, fmap fromIntegral (stuckFilter ^. #minAttempts)) findStuckTimersStmt   where     cutoff = fmap (\age -> addUTCTime (negate age) now) (stuckFilter ^. #minAge) -{- | Move every timer stranded in @Firing@ for at least @olderThan@ back to-@Scheduled@. The statement preserves @fire_at@, so a due timer becomes-claimable on the same worker pass. Returns the number of rows requeued.--}+-- | Move every timer stranded in @Firing@ for at least @olderThan@ back to+-- @Scheduled@. The statement preserves @fire_at@, so a due timer becomes+-- claimable on the same worker pass. Returns the number of rows requeued. requeueStuckTimers :: (Store :> es) => NominalDiffTime -> UTCTime -> Eff es Int requeueStuckTimers olderThan now =-    runTransaction $-        Tx.statement cutoff requeueStuckTimersStmt+  runTransaction $+    Tx.statement cutoff requeueStuckTimersStmt   where     cutoff = addUTCTime (negate olderThan) now -{- | Move a timer from @Firing@ back to @Scheduled@ so the ordinary claim loop-re-fires it. Leaves @fire_at@ unchanged, so a due timer becomes immediately-re-claimable. Idempotent: only @firing@ rows match, so re-running on an-already-requeued row affects nothing. Returns 'True' when a row changed.--}+-- | Move a timer from @Firing@ back to @Scheduled@ so the ordinary claim loop+-- re-fires it. Leaves @fire_at@ unchanged, so a due timer becomes immediately+-- re-claimable. Idempotent: only @firing@ rows match, so re-running on an+-- already-requeued row affects nothing. Returns 'True' when a row changed. requeueStuckTimer :: (Store :> es) => TimerId -> Eff es Bool requeueStuckTimer timerId =-    runTransaction $-        Tx.statement (timerIdToUuid timerId) requeueStuckTimerStmt+  runTransaction $+    Tx.statement (timerIdToUuid timerId) requeueStuckTimerStmt -{- | Move a timer from @Scheduled@ or @Firing@ to the terminal @Cancelled@-state so it never fires. Terminal rows (@fired@, @cancelled@, @dead@) are left-untouched. Idempotent. Returns 'True' when a row changed.--}+-- | Move a timer from @Scheduled@ or @Firing@ to the terminal @Cancelled@+-- state so it never fires. Terminal rows (@fired@, @cancelled@, @dead@) are left+-- untouched. Idempotent. Returns 'True' when a row changed. cancelTimer :: (Store :> es) => TimerId -> Eff es Bool cancelTimer timerId =-    runTransaction $-        Tx.statement (timerIdToUuid timerId) cancelTimerStmt+  runTransaction $+    Tx.statement (timerIdToUuid timerId) cancelTimerStmt -{- | Move a timer from @Scheduled@ or @Firing@ to the terminal @Dead@ state,-recording @reason@ in @last_error@ so an operator can see why it was abandoned-(@SELECT * FROM keiro_timers WHERE status = 'dead'@). Terminal rows are left-untouched. Idempotent. Returns 'True' when a row changed.--}+-- | Move a timer from @Scheduled@ or @Firing@ to the terminal @Dead@ state,+-- recording @reason@ in @last_error@ so an operator can see why it was abandoned+-- (@SELECT * FROM keiro_timers WHERE status = 'dead'@). Terminal rows are left+-- untouched. Idempotent. Returns 'True' when a row changed. deadLetterTimer :: (Store :> es) => TimerId -> Text -> Eff es Bool deadLetterTimer timerId reason =-    runTransaction $-        Tx.statement (timerIdToUuid timerId, reason) deadLetterTimerStmt+  runTransaction $+    Tx.statement (timerIdToUuid timerId, reason) deadLetterTimerStmt  scheduleTimerStmt :: Statement (UUID, Text, Text, UTCTime, Value, Text) () scheduleTimerStmt =-    preparable-        """-        INSERT INTO keiro.keiro_timers-          (timer_id, process_manager_name, correlation_id, fire_at, payload, status)-        VALUES-          ($1, $2, $3, $4, $5, $6)-        ON CONFLICT (timer_id) DO UPDATE-          SET process_manager_name = EXCLUDED.process_manager_name,-              correlation_id = EXCLUDED.correlation_id,-              fire_at = EXCLUDED.fire_at,-              payload = EXCLUDED.payload,-              status = EXCLUDED.status,-              updated_at = now()-          WHERE keiro_timers.status = 'scheduled'-        """-        ( contrazip6-            (E.param (E.nonNullable E.uuid))-            (E.param (E.nonNullable E.text))-            (E.param (E.nonNullable E.text))-            (E.param (E.nonNullable E.timestamptz))-            (E.param (E.nonNullable E.jsonb))-            (E.param (E.nonNullable E.text))-        )-        D.noResult+  preparable+    """+    INSERT INTO keiro.keiro_timers+      (timer_id, process_manager_name, correlation_id, fire_at, payload, status)+    VALUES+      ($1, $2, $3, $4, $5, $6)+    ON CONFLICT (timer_id) DO UPDATE+      SET process_manager_name = EXCLUDED.process_manager_name,+          correlation_id = EXCLUDED.correlation_id,+          fire_at = EXCLUDED.fire_at,+          payload = EXCLUDED.payload,+          status = EXCLUDED.status,+          updated_at = now()+      WHERE keiro_timers.status = 'scheduled'+    """+    ( contrazip6+        (E.param (E.nonNullable E.uuid))+        (E.param (E.nonNullable E.text))+        (E.param (E.nonNullable E.text))+        (E.param (E.nonNullable E.timestamptz))+        (E.param (E.nonNullable E.jsonb))+        (E.param (E.nonNullable E.text))+    )+    D.noResult  scheduleTimerOnceStmt :: Statement (UUID, Text, Text, UTCTime, Value, Text) Bool scheduleTimerOnceStmt =-    preparable-        """-        INSERT INTO keiro.keiro_timers-          (timer_id, process_manager_name, correlation_id, fire_at, payload, status)-        VALUES-          ($1, $2, $3, $4, $5, $6)-        ON CONFLICT (timer_id) DO NOTHING-        """-        ( contrazip6-            (E.param (E.nonNullable E.uuid))-            (E.param (E.nonNullable E.text))-            (E.param (E.nonNullable E.text))-            (E.param (E.nonNullable E.timestamptz))-            (E.param (E.nonNullable E.jsonb))-            (E.param (E.nonNullable E.text))-        )-        ((> 0) <$> D.rowsAffected)+  preparable+    """+    INSERT INTO keiro.keiro_timers+      (timer_id, process_manager_name, correlation_id, fire_at, payload, status)+    VALUES+      ($1, $2, $3, $4, $5, $6)+    ON CONFLICT (timer_id) DO NOTHING+    """+    ( contrazip6+        (E.param (E.nonNullable E.uuid))+        (E.param (E.nonNullable E.text))+        (E.param (E.nonNullable E.text))+        (E.param (E.nonNullable E.timestamptz))+        (E.param (E.nonNullable E.jsonb))+        (E.param (E.nonNullable E.text))+    )+    ((> 0) <$> D.rowsAffected)  claimDueTimerStmt :: Statement UTCTime (Maybe TimerRow) claimDueTimerStmt =-    preparable-        """-        WITH due AS (-          SELECT timer_id-          FROM keiro.keiro_timers-          WHERE status = 'scheduled'-            AND fire_at <= $1-          ORDER BY fire_at, timer_id-          LIMIT 1-          FOR UPDATE SKIP LOCKED-        )-        UPDATE keiro.keiro_timers kt-        SET status = 'firing',-            attempts = kt.attempts + 1,-            updated_at = now()-        FROM due-        WHERE kt.timer_id = due.timer_id-        RETURNING kt.timer_id, kt.process_manager_name, kt.correlation_id, kt.fire_at,-          kt.payload, kt.status, kt.attempts, kt.fired_event_id-        """-        (E.param (E.nonNullable E.timestamptz))-        (D.rowMaybe timerRowDecoder)+  preparable+    """+    WITH due AS (+      SELECT timer_id+      FROM keiro.keiro_timers+      WHERE status = 'scheduled'+        AND fire_at <= $1+      ORDER BY fire_at, timer_id+      LIMIT 1+      FOR UPDATE SKIP LOCKED+    )+    UPDATE keiro.keiro_timers kt+    SET status = 'firing',+        attempts = kt.attempts + 1,+        updated_at = now()+    FROM due+    WHERE kt.timer_id = due.timer_id+    RETURNING kt.timer_id, kt.process_manager_name, kt.correlation_id, kt.fire_at,+      kt.payload, kt.status, kt.attempts, kt.fired_event_id+    """+    (E.param (E.nonNullable E.timestamptz))+    (D.rowMaybe timerRowDecoder)  markTimerFiredStmt :: Statement (UUID, UUID) Bool markTimerFiredStmt =-    preparable-        """-        UPDATE keiro.keiro_timers-        SET status = 'fired',-            fired_event_id = $2,-            updated_at = now()-        WHERE timer_id = $1-          AND status = 'firing'-        """-        ( contrazip2-            (E.param (E.nonNullable E.uuid))-            (E.param (E.nonNullable E.uuid))-        )-        ((> 0) <$> D.rowsAffected)+  preparable+    """+    UPDATE keiro.keiro_timers+    SET status = 'fired',+        fired_event_id = $2,+        updated_at = now()+    WHERE timer_id = $1+      AND status = 'firing'+    """+    ( contrazip2+        (E.param (E.nonNullable E.uuid))+        (E.param (E.nonNullable E.uuid))+    )+    ((> 0) <$> D.rowsAffected)  countDueTimersStmt :: Statement UTCTime Int countDueTimersStmt =-    preparable-        """-        SELECT count(*)-        FROM keiro.keiro_timers-        WHERE status = 'scheduled'-          AND fire_at <= $1-        """-        (E.param (E.nonNullable E.timestamptz))-        (D.singleRow (fromIntegral <$> D.column (D.nonNullable D.int8)))+  preparable+    """+    SELECT count(*)+    FROM keiro.keiro_timers+    WHERE status = 'scheduled'+      AND fire_at <= $1+    """+    (E.param (E.nonNullable E.timestamptz))+    (D.singleRow (fromIntegral <$> D.column (D.nonNullable D.int8)))  countStuckTimersStmt :: Statement (Maybe UTCTime, Maybe Int64) Int countStuckTimersStmt =-    preparable-        """-        SELECT count(*)-        FROM keiro.keiro_timers-        WHERE status = 'firing'-          AND ($1::timestamptz IS NULL OR updated_at <= $1)-          AND ($2::bigint IS NULL OR attempts >= $2)-        """-        ( contrazip2-            (E.param (E.nullable E.timestamptz))-            (E.param (E.nullable E.int8))-        )-        (D.singleRow (fromIntegral <$> D.column (D.nonNullable D.int8)))+  preparable+    """+    SELECT count(*)+    FROM keiro.keiro_timers+    WHERE status = 'firing'+      AND ($1::timestamptz IS NULL OR updated_at <= $1)+      AND ($2::bigint IS NULL OR attempts >= $2)+    """+    ( contrazip2+        (E.param (E.nullable E.timestamptz))+        (E.param (E.nullable E.int8))+    )+    (D.singleRow (fromIntegral <$> D.column (D.nonNullable D.int8)))  findStuckTimersStmt :: Statement (Maybe UTCTime, Maybe Int64) [TimerRow] findStuckTimersStmt =-    preparable-        """-        SELECT timer_id, process_manager_name, correlation_id, fire_at,-          payload, status, attempts, fired_event_id-        FROM keiro.keiro_timers-        WHERE status = 'firing'-          AND ($1::timestamptz IS NULL OR updated_at <= $1)-          AND ($2::bigint IS NULL OR attempts >= $2)-        ORDER BY updated_at, timer_id-        """-        ( contrazip2-            (E.param (E.nullable E.timestamptz))-            (E.param (E.nullable E.int8))-        )-        (D.rowList timerRowDecoder)+  preparable+    """+    SELECT timer_id, process_manager_name, correlation_id, fire_at,+      payload, status, attempts, fired_event_id+    FROM keiro.keiro_timers+    WHERE status = 'firing'+      AND ($1::timestamptz IS NULL OR updated_at <= $1)+      AND ($2::bigint IS NULL OR attempts >= $2)+    ORDER BY updated_at, timer_id+    """+    ( contrazip2+        (E.param (E.nullable E.timestamptz))+        (E.param (E.nullable E.int8))+    )+    (D.rowList timerRowDecoder)  requeueStuckTimersStmt :: Statement UTCTime Int requeueStuckTimersStmt =-    preparable-        """-        UPDATE keiro.keiro_timers-        SET status = 'scheduled',-            updated_at = now()-        WHERE status = 'firing'-          AND updated_at <= $1-        """-        (E.param (E.nonNullable E.timestamptz))-        (fromIntegral <$> D.rowsAffected)+  preparable+    """+    UPDATE keiro.keiro_timers+    SET status = 'scheduled',+        updated_at = now()+    WHERE status = 'firing'+      AND updated_at <= $1+    """+    (E.param (E.nonNullable E.timestamptz))+    (fromIntegral <$> D.rowsAffected)  requeueStuckTimerStmt :: Statement UUID Bool requeueStuckTimerStmt =-    preparable-        """-        UPDATE keiro.keiro_timers-        SET status = 'scheduled',-            updated_at = now()-        WHERE timer_id = $1-          AND status = 'firing'-        """-        (E.param (E.nonNullable E.uuid))-        ((> 0) <$> D.rowsAffected)+  preparable+    """+    UPDATE keiro.keiro_timers+    SET status = 'scheduled',+        updated_at = now()+    WHERE timer_id = $1+      AND status = 'firing'+    """+    (E.param (E.nonNullable E.uuid))+    ((> 0) <$> D.rowsAffected)  cancelTimerStmt :: Statement UUID Bool cancelTimerStmt =-    preparable-        """-        UPDATE keiro.keiro_timers-        SET status = 'cancelled',-            updated_at = now()-        WHERE timer_id = $1-          AND status IN ('scheduled', 'firing')-        """-        (E.param (E.nonNullable E.uuid))-        ((> 0) <$> D.rowsAffected)+  preparable+    """+    UPDATE keiro.keiro_timers+    SET status = 'cancelled',+        updated_at = now()+    WHERE timer_id = $1+      AND status IN ('scheduled', 'firing')+    """+    (E.param (E.nonNullable E.uuid))+    ((> 0) <$> D.rowsAffected)  deadLetterTimerStmt :: Statement (UUID, Text) Bool deadLetterTimerStmt =-    preparable-        """-        UPDATE keiro.keiro_timers-        SET status = 'dead',-            last_error = $2,-            updated_at = now()-        WHERE timer_id = $1-          AND status IN ('scheduled', 'firing')-        """-        ( contrazip2-            (E.param (E.nonNullable E.uuid))-            (E.param (E.nonNullable E.text))-        )-        ((> 0) <$> D.rowsAffected)+  preparable+    """+    UPDATE keiro.keiro_timers+    SET status = 'dead',+        last_error = $2,+        updated_at = now()+    WHERE timer_id = $1+      AND status IN ('scheduled', 'firing')+    """+    ( contrazip2+        (E.param (E.nonNullable E.uuid))+        (E.param (E.nonNullable E.text))+    )+    ((> 0) <$> D.rowsAffected)  timerRowDecoder :: D.Row TimerRow timerRowDecoder =-    TimerRow-        <$> (TimerId <$> D.column (D.nonNullable D.uuid))-        <*> D.column (D.nonNullable D.text)-        <*> D.column (D.nonNullable D.text)-        <*> D.column (D.nonNullable D.timestamptz)-        <*> D.column (D.nonNullable D.jsonb)-        <*> D.column (D.nonNullable (D.refine statusFromText D.text))-        <*> (fromIntegral <$> D.column (D.nonNullable D.int8))-        <*> (fmap EventId <$> D.column (D.nullable D.uuid))+  TimerRow+    <$> (TimerId <$> D.column (D.nonNullable D.uuid))+    <*> D.column (D.nonNullable D.text)+    <*> D.column (D.nonNullable D.text)+    <*> D.column (D.nonNullable D.timestamptz)+    <*> D.column (D.nonNullable D.jsonb)+    <*> D.column (D.nonNullable (D.refine statusFromText D.text))+    <*> (fromIntegral <$> D.column (D.nonNullable D.int8))+    <*> (fmap EventId <$> D.column (D.nullable D.uuid))  statusToText :: TimerStatus -> Text statusToText = \case-    Scheduled -> "scheduled"-    Firing -> "firing"-    Fired -> "fired"-    Cancelled -> "cancelled"-    Dead -> "dead"+  Scheduled -> "scheduled"+  Firing -> "firing"+  Fired -> "fired"+  Cancelled -> "cancelled"+  Dead -> "dead"  statusFromText :: Text -> Either Text TimerStatus statusFromText = \case-    "scheduled" -> Right Scheduled-    "firing" -> Right Firing-    "fired" -> Right Fired-    "cancelled" -> Right Cancelled-    "dead" -> Right Dead-    other -> Left ("unknown keiro_timers.status: " <> other)+  "scheduled" -> Right Scheduled+  "firing" -> Right Firing+  "fired" -> Right Fired+  "cancelled" -> Right Cancelled+  "dead" -> Right Dead+  other -> Left ("unknown keiro_timers.status: " <> other)  timerIdToUuid :: TimerId -> UUID timerIdToUuid (TimerId uuid) = uuid
src/Keiro/Timer/Types.hs view
@@ -1,35 +1,32 @@-{- | Identity and request types for durable timers, separated from their SQL-storage ("Keiro.Timer.Schema") so process-manager code can construct timer-requests without depending on the persistence layer.--}-module Keiro.Timer.Types (-    TimerId (..),+-- | Identity and request types for durable timers, separated from their SQL+-- storage ("Keiro.Timer.Schema") so process-manager code can construct timer+-- requests without depending on the persistence layer.+module Keiro.Timer.Types+  ( TimerId (..),     TimerRequest (..),-)+  ) where  import Data.UUID (UUID) import Keiro.Prelude -{- | A timer's stable identifier. A caller-chosen id makes scheduling-idempotent (rescheduling the same id updates rather than duplicates).--}+-- | A timer's stable identifier. A caller-chosen id makes scheduling+-- idempotent (rescheduling the same id updates rather than duplicates). newtype TimerId = TimerId UUID-    deriving stock (Generic, Eq, Ord, Show)--{- | A request to schedule a timer.+  deriving stock (Generic, Eq, Ord, Show) -* 'timerId' — stable id; rescheduling the same id is idempotent.-* 'processManagerName' \/ 'correlationId' — identify the saga instance the-  timer belongs to, so the firing can be routed back to it.-* 'fireAt' — the earliest time the timer becomes due.-* 'payload' — opaque JSON carried through to the @fire@ action.--}+-- | A request to schedule a timer.+--+-- * 'timerId' — stable id; rescheduling the same id is idempotent.+-- * 'processManagerName' \/ 'correlationId' — identify the saga instance the+--   timer belongs to, so the firing can be routed back to it.+-- * 'fireAt' — the earliest time the timer becomes due.+-- * 'payload' — opaque JSON carried through to the @fire@ action. data TimerRequest = TimerRequest-    { timerId :: !TimerId-    , processManagerName :: !Text-    , correlationId :: !Text-    , fireAt :: !UTCTime-    , payload :: !Value-    }-    deriving stock (Generic, Eq, Show)+  { timerId :: !TimerId,+    processManagerName :: !Text,+    correlationId :: !Text,+    fireAt :: !UTCTime,+    payload :: !Value+  }+  deriving stock (Generic, Eq, Show)
src/Keiro/Wake.hs view
@@ -1,48 +1,47 @@-{- | A wake signal for keiro's poll-loop workers (EP-50, LISTEN/NOTIFY push delivery).--keiro's background workers — the workflow resume worker, the durable-timer worker,-the outbox publisher — make progress by polling: run one "claim, process, commit"-pass, then sleep a fixed interval. That fixed sleep is also the worst-case latency-(the resume worker's default is a full second). This module lets a worker instead-/wait to be woken/: it blocks until either a relevant append notification arrives —-meaning "something was appended, go look" — or a bounded fallback timeout elapses.--== Where the wake comes from (no new connection)--The kiroku event store already fires a Postgres @NOTIFY@ on channel @\<schema\>.events@-(default @kiroku.events@) on every append, via a @notify_events()@ trigger on the-@streams@ table, and already runs __one dedicated long-lived listener connection per-store__ ('Kiroku.Store.Notification.Notifier', started once by-'Kiroku.Store.Connection.withStore'). That listener fans every notification out to an-in-process broadcast channel, @notifier.tickChan :: 'Control.Concurrent.STM.TChan' ()@.--A 'WakeSignal' built by 'wakeSignalFromStore' duplicates that broadcast channel-('Control.Concurrent.STM.dupTChan' — an STM operation, __not__ a database connection),-so N keiro workers over one store share the single existing listener connection and N-cheap STM cursors. Push therefore adds __zero__ new long-lived connections: the only-listener connection is kiroku's pre-existing @kiroku-listener@, amortized across all-subscribers. The query pool is sized exactly as before.--== Push is an optimization over a durable poll, never a replacement--A Postgres @NOTIFY@ is best-effort: if the listener is momentarily disconnected the-notification is dropped, and the payload is advisory. So correctness must never depend-on a notification arriving. 'waitForWake' always takes a fallback timeout: a missed-notification only delays the next pass to that fallback interval, exactly as the old-fixed-poll loop did. The channel and payload are kiroku's-(@\<schema\>.events@; @stream_name,stream_id,stream_version@); keiro treats the-notification as an opaque wake and re-queries durably, so it ignores the payload.--}-module Keiro.Wake (-    WakeSignal (..),+-- | A wake signal for keiro's poll-loop workers (EP-50, LISTEN/NOTIFY push delivery).+--+-- keiro's background workers — the workflow resume worker, the durable-timer worker,+-- the outbox publisher — make progress by polling: run one "claim, process, commit"+-- pass, then sleep a fixed interval. That fixed sleep is also the worst-case latency+-- (the resume worker's default is a full second). This module lets a worker instead+-- /wait to be woken/: it blocks until either a relevant append notification arrives —+-- meaning "something was appended, go look" — or a bounded fallback timeout elapses.+--+-- == Where the wake comes from (no new connection)+--+-- The kiroku event store already fires a Postgres @NOTIFY@ on channel @\<schema\>.events@+-- (default @kiroku.events@) on every append, via a @notify_events()@ trigger on the+-- @streams@ table, and already runs __one dedicated long-lived listener connection per+-- store__ ('Kiroku.Store.Notification.Notifier', started once by+-- 'Kiroku.Store.Connection.withStore'). That listener fans every notification out to an+-- in-process broadcast channel, @notifier.tickChan :: 'Control.Concurrent.STM.TChan' ()@.+--+-- A 'WakeSignal' built by 'wakeSignalFromStore' duplicates that broadcast channel+-- ('Control.Concurrent.STM.dupTChan' — an STM operation, __not__ a database connection),+-- so N keiro workers over one store share the single existing listener connection and N+-- cheap STM cursors. Push therefore adds __zero__ new long-lived connections: the only+-- listener connection is kiroku's pre-existing @kiroku-listener@, amortized across all+-- subscribers. The query pool is sized exactly as before.+--+-- == Push is an optimization over a durable poll, never a replacement+--+-- A Postgres @NOTIFY@ is best-effort: if the listener is momentarily disconnected the+-- notification is dropped, and the payload is advisory. So correctness must never depend+-- on a notification arriving. 'waitForWake' always takes a fallback timeout: a missed+-- notification only delays the next pass to that fallback interval, exactly as the old+-- fixed-poll loop did. The channel and payload are kiroku's+-- (@\<schema\>.events@; @stream_name,stream_id,stream_version@); keiro treats the+-- notification as an opaque wake and re-queries durably, so it ignores the payload.+module Keiro.Wake+  ( WakeSignal (..),     WakeReason (..),     wakeSignalFromStore,     neverWake,-)+  ) where -import Control.Concurrent.STM (-    TChan,+import Control.Concurrent.STM+  ( TChan,     atomically,     check,     dupTChan,@@ -51,62 +50,57 @@     readTChan,     readTVar,     registerDelay,- )+  ) import Kiroku.Store.Connection (KirokuStore (..)) import Kiroku.Store.Notification (Notifier (..)) -{- | Why a 'waitForWake' returned: a notification arrived, or the fallback timeout-elapsed. Both mean "run another pass"; the distinction is available for telemetry.--}+-- | Why a 'waitForWake' returned: a notification arrived, or the fallback timeout+-- elapsed. Both mean "run another pass"; the distinction is available for telemetry. data WakeReason = WokenByNotify | WokenByTimeout-    deriving stock (Eq, Show)+  deriving stock (Eq, Show) -{- | A source of "something was appended, go look" wake-ups, layered over a bounded-fallback timeout so a missed notification never stalls progress.--}+-- | A source of "something was appended, go look" wake-ups, layered over a bounded+-- fallback timeout so a missed notification never stalls progress. newtype WakeSignal = WakeSignal-    { waitForWake :: Int -> IO WakeReason-    {- ^ Block until a notification arrives OR the given fallback timeout-    (microseconds) elapses, whichever is first. Returns which happened.-    -}-    }+  { -- | Block until a notification arrives OR the given fallback timeout+    --     (microseconds) elapses, whichever is first. Returns which happened.+    waitForWake :: Int -> IO WakeReason+  } -{- | Build a 'WakeSignal' from a running kiroku store's notifier. Duplicates the-store's broadcast tick channel ('dupTChan') __once__ here, so this consumer has its-own cursor and never steals another consumer's ticks, and so ticks arriving between-waits queue in the duplicated channel rather than being lost. Opens __no__ new-database connection: it rides the single dedicated listener connection the store-already holds.--}+-- | Build a 'WakeSignal' from a running kiroku store's notifier. Duplicates the+-- store's broadcast tick channel ('dupTChan') __once__ here, so this consumer has its+-- own cursor and never steals another consumer's ticks, and so ticks arriving between+-- waits queue in the duplicated channel rather than being lost. Opens __no__ new+-- database connection: it rides the single dedicated listener connection the store+-- already holds. wakeSignalFromStore :: KirokuStore -> IO WakeSignal wakeSignalFromStore store = do-    myChan <- atomically (dupTChan (tickChan (notifier store)))-    pure (WakeSignal (waitOn myChan))+  myChan <- atomically (dupTChan (tickChan (notifier store)))+  pure (WakeSignal (waitOn myChan))   where     waitOn :: TChan () -> Int -> IO WakeReason     waitOn myChan timeoutMicros = do-        timer <- registerDelay timeoutMicros-        atomically $-            ( do-                -- A tick is queued: collapse any backlog so one wait returns once per-                -- "there is new work" episode (the worker re-queries durably anyway).-                _ <- readTChan myChan-                drain myChan-                pure WokenByNotify-            )-                `orElse` (readTVar timer >>= check >> pure WokenByTimeout)+      timer <- registerDelay timeoutMicros+      atomically $+        ( do+            -- A tick is queued: collapse any backlog so one wait returns once per+            -- "there is new work" episode (the worker re-queries durably anyway).+            _ <- readTChan myChan+            drain myChan+            pure WokenByNotify+        )+          `orElse` (readTVar timer >>= check >> pure WokenByTimeout)      drain ch = do-        empty <- isEmptyTChan ch-        if empty then pure () else readTChan ch >> drain ch+      empty <- isEmptyTChan ch+      if empty then pure () else readTChan ch >> drain ch -{- | A 'WakeSignal' that never fires a notification — every wait elapses the fallback-timeout. Used to simulate "all NOTIFYs dropped" (proving push is an optimization over-the durable poll) and to give a fixed-poll worker an unchanged cadence under the same-push-aware driver.--}+-- | A 'WakeSignal' that never fires a notification — every wait elapses the fallback+-- timeout. Used to simulate "all NOTIFYs dropped" (proving push is an optimization over+-- the durable poll) and to give a fixed-poll worker an unchanged cadence under the same+-- push-aware driver. neverWake :: WakeSignal neverWake = WakeSignal $ \timeoutMicros -> do-    timer <- registerDelay timeoutMicros-    atomically (readTVar timer >>= check)-    pure WokenByTimeout+  timer <- registerDelay timeoutMicros+  atomically (readTVar timer >>= check)+  pure WokenByTimeout
src/Keiro/Workflow.hs view
@@ -1,1087 +1,1051 @@ {-# LANGUAGE TypeFamilies #-} -{- | The durable workflow runtime: the @Workflow@ effect, named-step-journaling, replay, and suspension.--== What this gives you--Write a long-running process as an ordinary @effectful@ computation and run-it with 'runWorkflow'. Each @'step' name action@ either runs @action@ and-records ("journals") its result, or — on a replay after a crash — returns the-previously recorded result /without/ re-running the side effect. The journal-is a kiroku stream named @wf:\<name\>-\<id\>@ ('workflowStreamName'); there is-no separate history table. Because a workflow can pause (waiting for a timer,-an external signal, or a child), 'runWorkflow' returns a 'WorkflowOutcome'-('Completed' or 'Suspended').--Step side effects are at-least-once across process crashes. If the process-crashes after @action@ runs but before the journal append commits, a later-resume has no record of that step and runs @action@ again. Step bodies that call-external systems must therefore be idempotent, typically by deriving an-idempotency key from the workflow identity and step name and passing it to the-external system.--Replay is keyed by step name, not by source position or code identity. Renaming-a step intentionally orphans the old journal entry and runs the renamed step as-new work; changing the meaning of a step while keeping the same name is the-author's responsibility. Use 'patch' for cross-cutting workflow-body changes-that need an explicit old/new branch.--== Contract recap for downstream plans (the v2 MasterPlan)--* The authoring surface is the @Workflow@ effect with 'step', 'awaitStep',-  'currentWorkflow', and 'freshOrdinal'. Add new primitives (sleep,-  awakeable, child) as functions that go /through/ this effect so a single-  import stays the workflow surface.-* 'awaitStep' is the suspension primitive every wake source builds on: it-  returns a journaled result if present, otherwise runs an idempotent-  /arming/ action once and suspends the run. The arming action MUST be-  idempotent — a suspended-then-resumed workflow re-enters 'awaitStep' from-  the top on every resume until the result is journaled, so it re-runs @arm@-  each time (e.g. schedule a timer with a deterministic id so repeats-  collapse to a no-op).-* A wake source's external completion path (a timer firing,-  @signalAwakeable@, a child finishing) calls 'appendJournalEntry' (or-  'appendJournalEntryReturningId') with a 'StepRecorded' whose @stepName@ is-  the awaited step name; the next 'runWorkflow' then takes the 'awaitStep'-  hit path and proceeds.-* The journal codec ('workflowJournalCodec') and the reserved step-name-  prefixes ('sleepStepPrefix' = @"sleep:"@, 'awakeableStepPrefix' = @"awk:"@,-  'childStepPrefix' = @"child:"@) are integration contracts: suspensions are-  journaled as ordinary 'StepRecorded' events with these prefixes, never as-  new event types, so the replay loop stays uniform.-* Per-run options live in one record, 'WorkflowRunOptions' (EP-41 adds a-  snapshot policy, EP-44 adds metrics/tracer); 'runWorkflowWith' is the-  single canonical entry EP-42's resume worker re-invokes through.-* The derived @keiro_workflows@ instance row is maintained by journal append-  transactions. Terminal markers ('WorkflowCompleted', 'WorkflowCancelled',-  'WorkflowFailed') freeze the instance as completed/cancelled/failed, and the-  resume worker uses its attempt/lease fields for crash recovery.-* Discovery (EP-42) is 'findUnfinishedWorkflowIds' plus 'completedStepName';-  it needs no kiroku prefix subscription.--> __Build gotcha__ (EP-38's migration adds @keiro_workflow_steps@): adding a-> new @.sql@ file under @keiro-migrations/sql-migrations/@ does not trigger-> recompilation of @Keiro.Migrations@ (cabal says "Up to date" even with-> @-fforce-recomp@, because @embedDir@ is a Template Haskell directory read-> GHC's recompilation checker does not track per-file). After adding a-> migration, edit a comment in @keiro-migrations/src/Keiro/Migrations.hs@ or-> run @cabal clean@ before building.--}-module Keiro.Workflow (-    -- * The effect and authoring surface-    Workflow,-    step,-    awaitStep,-    currentWorkflow,-    currentRunGeneration,-    freshOrdinal,-    continueAsNew,-    restoreSeed,-    patch,--    -- * Running a workflow-    runWorkflow,-    runWorkflowWith,-    WorkflowRunOptions (..),-    LeaseHeartbeat (..),-    defaultWorkflowRunOptions,--    -- * Journal append helpers (used by wake-source plans)-    JournalAppendOutcome (..),-    prepareJournalAppend,-    appendJournalEntry,-    appendJournalEntryReturningId,-    deterministicJournalId,--    -- * Errors thrown by the runtime-    WorkflowError (..),-    WorkflowLeaseLost (..),--    -- * Re-exported core contracts-    module Keiro.Workflow.Types,-    WorkflowStepRow (..),-    recordStepTx,-    loadStepIndex,-    stepExists,-    currentGeneration,-    findUnfinishedWorkflowIds,-    setWorkflowWakeAfterTx,-    clearWorkflowWakeAfterTx,-)-where--import Control.Exception (Exception)-import Data.Aeson qualified as Aeson-import Data.IORef (-    IORef,-    atomicModifyIORef',-    newIORef,-    readIORef,- )-import Data.Int (Int32)-import Data.Map.Strict (Map)-import Data.Map.Strict qualified as Map-import Data.Set (Set)-import Data.Set qualified as Set-import Data.Text qualified as Text-import Data.Time (NominalDiffTime)-import Data.UUID.V5 qualified as UUID.V5-import Effectful (Dispatch (..), DispatchOf, Eff, Effect, IOE, (:>))-import Effectful.Dispatch.Dynamic (EffectHandler, interpret, localSeqUnlift, send)-import Effectful.Error.Static (Error, tryError)-import Effectful.Exception (bracket_, catch, throwIO)-import Keiro.Codec (decodeRecorded, encodeForAppendWithMetadata)-import Keiro.EventStream (SnapshotPolicy (..), Terminality (..))-import Keiro.Prelude-import Keiro.Snapshot (SnapshotMissReason (..))-import Keiro.Snapshot.Policy (shouldSnapshot)-import Keiro.Telemetry (-    KeiroMetrics,-    Tracer,-    recordSnapshotDecodeFailures,-    recordSnapshotReadHits,-    recordSnapshotReadMisses,-    recordSnapshotWriteFailures,-    recordWorkflowActive,-    recordWorkflowJournalLength,-    recordWorkflowStepExecuted,-    recordWorkflowStepReplayed,-    withWorkflowSpan,- )-import Keiro.Workflow.Instance (-    WorkflowStatus (..),-    markInstanceSuspended,-    renewInstanceLease,-    upsertInstanceTx,- )-import Keiro.Workflow.Schema (WorkflowStepRow (..), clearWorkflowWakeAfterTx, currentGeneration, findUnfinishedWorkflowIds, loadStepIndex, lockWorkflowStepTx, lookupStepResult, lookupStepResultTx, recordStepTx, setWorkflowWakeAfterTx, stepExists)-import Keiro.Workflow.Snapshot (lookupWorkflowSnapshot, writeWorkflowSnapshot)-import Keiro.Workflow.Types-import Kiroku.Store.Effect (Store)-import Kiroku.Store.Error (StoreError)-import Kiroku.Store.Read (readStreamForwardStream)-import Kiroku.Store.Transaction (AppendConflict, appendToStreamTx, prepareEventsIO, runTransaction)-import Kiroku.Store.Types (AppendResult (..), EventData, EventId (..), ExpectedVersion (..), StreamId, StreamVersion (..))-import Streamly.Data.Fold qualified as Fold-import Streamly.Data.Stream qualified as Streamly-import System.IO.Unsafe (unsafePerformIO)-import "hasql-transaction" Hasql.Transaction qualified as Tx---- ------------------------------------------------------------------------------ The effect--- -----------------------------------------------------------------------------{- | The durable workflow effect. Its operations are interpreted by-'runWorkflow' / 'runWorkflowWith', which journal and replay them.--}-data Workflow :: Effect where-    {- | Run a side-effecting action under a name, journaling its result; on-    replay, return the recorded result without re-running the action.-    -}-    Step :: (Aeson.ToJSON a, Aeson.FromJSON a) => StepName -> m a -> Workflow m a-    {- | Return the awaited step's journaled result, or run the (idempotent)-    arming action once and suspend the run.-    -}-    Await :: (Aeson.FromJSON a) => StepName -> m () -> Workflow m a-    -- | The running workflow's identity (for keying wake sources).-    CurrentWorkflow :: Workflow m (WorkflowName, WorkflowId)-    -- | The journal generation this run is operating on.-    CurrentRunGeneration :: Workflow m Int-    -- | A per-run, per-namespace counter for deterministic ordinal step names.-    FreshOrdinal :: Text -> Workflow m Int-    {- | EP-48: snapshot the carried seed, rotate onto a fresh journal generation,-    and unwind this run; the next run/resume continues from the seed. Never-    returns to the caller within this run (result type is fully polymorphic).-    -}-    ContinueAsNew :: (Aeson.ToJSON s) => s -> Workflow m a-    {- | EP-49: decide and journal a cross-cutting branch — returns the stable-    'Bool' branch decision for the given patch. Fresh instances get 'True'-    (new branch); instances already in flight when the patch shipped get-    'False' (old branch). The decision is journaled on first encounter and-    replayed verbatim thereafter.-    -}-    Patch :: PatchId -> Workflow m Bool--type instance DispatchOf Workflow = Dynamic--{- | Run @action@ under @name@, journaling its encoded result. On a replay where-@name@ is already journaled, the recorded result is returned and @action@ is-not run. If the process crashed after @action@ ran but before the journal-commit, the action runs again on resume: workflow step side effects are-at-least-once at the step boundary.--The returned value is always the JSON round-trip of the recorded result,-including on the first run. A lossy or rejecting @ToJSON@\/@FromJSON@ pair is-therefore observed immediately rather than only after a crash and replay.--Requires @'Aeson.ToJSON' a@ (to journal the result) and @'Aeson.FromJSON' a@-(to decode it on replay).--}-step :: (Workflow :> es, Aeson.ToJSON a, Aeson.FromJSON a) => StepName -> Eff es a -> Eff es a-step name action = send (Step name action)--{- | Look up @name@ in the journal. If a wake source has already recorded its-completion (a 'StepRecorded' whose @stepName@ is @name@, carrying the-resolved result), decode and return it. Otherwise run @arm@ exactly once-(the wake source's idempotent job — schedule a timer, register an awakeable,-spawn a child) and __suspend__ this run, so 'runWorkflow' returns 'Suspended'.--@arm@ must be idempotent: every resume re-runs it until the result is-journaled.--}-awaitStep :: (Workflow :> es, Aeson.FromJSON a) => StepName -> Eff es () -> Eff es a-awaitStep name arm = send (Await name arm)---- | The identity of the workflow currently running.-currentWorkflow :: (Workflow :> es) => Eff es (WorkflowName, WorkflowId)-currentWorkflow = send CurrentWorkflow--{- | The journal generation this run is operating on. Wake sources include it-in their durable identities so a generation opened by 'continueAsNew' never-collides with prior-generation rows.--}-currentRunGeneration :: (Workflow :> es) => Eff es Int-currentRunGeneration = send CurrentRunGeneration--{- | A per-run, per-namespace counter (starting at 0). Used by convenience-forms of wake sources (e.g. @sleep@ → @"sleep:0"@) to derive a deterministic,-replay-stable ordinal name. Note: ordinal names are only stable if the order-of @awaitStep@-style calls does not change across deploys; the named forms-are the stable primitives.--}-freshOrdinal :: (Workflow :> es) => Text -> Eff es Int-freshOrdinal namespace = send (FreshOrdinal namespace)--{- | Continue this workflow /as new/ (EP-48): snapshot the carried @seed@ onto a-fresh journal generation, journal a terminal rotation marker on the current-generation, and unwind this run. The next run or resume of the same logical-@('WorkflowName', 'WorkflowId')@ starts against the fresh generation, hydrated-from the seed, with an empty (bounded) journal.--This is how a workflow that runs an /unbounded/ number of steps — a poller, a-per-day rolling process — keeps its per-generation journal bounded so replay-and hydration stay fast forever. The result type is fully polymorphic (@a@)-because control never returns to the caller within /this/ run: the rotated-continuation runs in the next run/resume. Read the carried seed back at the top-of the workflow body with 'restoreSeed'.--}-continueAsNew :: (Workflow :> es, Aeson.ToJSON s) => s -> Eff es a-continueAsNew seed = send (ContinueAsNew seed)--{- | Restore the seed carried by the previous generation's 'continueAsNew', or-return @def@ on the first generation (EP-48). Implemented as an ordinary-journaled @step@ under the reserved 'continueSeedStepName': on a generation that-was rotated into, the seed step was journaled (and snapshotted) by the rotation,-so this @step@ hits it and returns the carried value without re-running; on the-very first generation it misses and records @def@. Call it once at the top of a-workflow body that uses 'continueAsNew'.--}-restoreSeed :: (Workflow :> es, Aeson.ToJSON s, Aeson.FromJSON s) => s -> Eff es s-restoreSeed def = step (StepName continueSeedStepName) (pure def)--{- | Decide a cross-cutting branch for an in-flight-vs-fresh code change, and-journal the decision so every later replay observes the same branch (EP-49).--@patch (PatchId "fraud-check-v2")@ returns 'True' only when that id was present-in 'activePatches' when this workflow generation first started. The generation-records its active set under 'patchSetStepName' exactly once; on the first-encounter each individual patch decision is journaled under @patch:\<patchId\>@,-and every replay returns the recorded 'Bool'. Add a patch id to 'activePatches'-in the deploy that introduces the corresponding 'patch' call; remove it only-after deleting that call from the workflow body.--This is an /escape hatch/ for changes that cross-cut multiple steps. For the-common case — one step changed — do __not__ use 'patch': rename the step's-'StepName' instead. A renamed step has no journaled history under its new name,-so its action runs fresh on the next replay, which is exactly the right-behaviour for a single-step change. Reach for 'patch' only when an in-flight-instance would be left incoherent by the new code (e.g. the change adds, removes,-or reorders steps, or changes the meaning of an already-journaled step result).--}-patch :: (Workflow :> es) => PatchId -> Eff es Bool-patch pid = send (Patch pid)---- ------------------------------------------------------------------------------ Per-run options--- -----------------------------------------------------------------------------{- | Lease renewal coordinates for a resume-worker-owned workflow run.--The runtime renews this lease immediately before each fresh step action and-unresolved await arm. Direct 'runWorkflow' calls leave it 'Nothing'.--}-data LeaseHeartbeat = LeaseHeartbeat-    { owner :: !Text-    , ttl :: !NominalDiffTime-    }-    deriving stock (Generic, Eq, Show)--{- | Options for a single workflow run. This is the canonical home for-per-run options across the v2 initiative — EP-41 adds the snapshot policy,-EP-44 adds metrics/tracer fields, all additive. Extend it additively; never-break the field set EP-38/EP-41 established.--}-data WorkflowRunOptions = WorkflowRunOptions-    { snapshotPolicy :: !(SnapshotPolicy WorkflowState)-    {- ^ When to persist a snapshot of the accumulated step-result map after a-    step append (and at completion, for 'OnTerminal'). Default 'Never'-    (EP-38 behaviour: every run/resume does a full version-0 replay).-    -}-    , pageSize :: !Int32-    -- ^ Page size for the journal pre-load read.-    , metrics :: !(Maybe KeiroMetrics)-    {- ^ EP-44: when 'Just', the runtime records the @keiro.workflow.*@ instruments-    (steps executed/replayed, active count, journal length). 'Nothing' is the-    no-op default, so a run with 'defaultWorkflowRunOptions' records nothing.-    -}-    , tracer :: !(Maybe Tracer)-    {- ^ EP-44: when 'Just', the runtime opens a @workflow \<name\>@ 'Internal' span-    around the run. 'Nothing' runs the body unwrapped.-    -}-    , activePatches :: !(Set PatchId)-    {- ^ Patch ids currently active in this deployed workflow code. A fresh-    workflow generation records this set once under 'patchSetStepName', and-    each 'patch' call returns 'True' iff its id was in that recorded set.-    -}-    , leaseHeartbeat :: !(Maybe LeaseHeartbeat)-    {- ^ Resume-worker lease coordinates. When present, fresh workflow-    boundaries renew the lease and throw 'WorkflowLeaseLost' if another owner-    has taken it. 'Nothing' keeps direct runs free of lease traffic.-    -}-    }-    deriving stock (Generic)--{- | Sensible defaults: no snapshotting, a journal pre-load page size of 100,-and no telemetry (metrics/tracer 'Nothing'). A default-options run replays-and behaves exactly as EP-38 did.--}-defaultWorkflowRunOptions :: WorkflowRunOptions-defaultWorkflowRunOptions =-    WorkflowRunOptions-        { snapshotPolicy = Never-        , pageSize = 100-        , metrics = Nothing-        , tracer = Nothing-        , activePatches = Set.empty-        , leaseHeartbeat = Nothing-        }---- ------------------------------------------------------------------------------ Errors and the suspension sentinel--- -----------------------------------------------------------------------------{- | Errors the workflow runtime raises (via 'throwIO', so they surface-through the surrounding store/IO error channel).--}-data WorkflowError-    = {- | A journaled step result could not be decoded into the type the-      replaying @step@/@awaitStep@ expects (step name, decode message). The-      result type changed incompatibly — a programmer error.-      -}-      WorkflowStepDecodeError !Text !Text-    | -- | A journal event could not be decoded during pre-load.-      WorkflowJournalDecodeError !Text-    | -- | A journal event could not be encoded for append.-      WorkflowJournalEncodeError !Text-    | -- | Appending a journal entry failed for a non-conflict reason.-      WorkflowJournalAppendError !Text-    deriving stock (Eq, Show)--instance Exception WorkflowError--{- | The resume worker no longer owns the workflow instance lease.--Thrown before a fresh step action or unresolved await arm, so the run stops-before performing further side effects. Resume workers classify this as a-lease skip rather than a workflow crash.--}-data WorkflowLeaseLost = WorkflowLeaseLost-    deriving stock (Eq, Show)--instance Exception WorkflowLeaseLost---- | Internal sentinel thrown to unwind a suspended run up to 'runWorkflowWith'.-data WorkflowSuspend = WorkflowSuspend-    deriving stock (Show)--instance Exception WorkflowSuspend---- | Internal sentinel thrown when a cancellation marker appears mid-run.-data WorkflowCancelPending = WorkflowCancelPending-    deriving stock (Show)--instance Exception WorkflowCancelPending--{- | Internal sentinel thrown by the 'ContinueAsNew' handler to unwind a-rotating run up to 'runWorkflowWith' (EP-48), carrying the JSON-encoded seed for-the next generation. Mirrors 'WorkflowSuspend': a non-returning unwind the run-entry point catches and turns into an outcome ('ContinuedAsNew').--}-newtype WorkflowRotate = WorkflowRotate Aeson.Value-    deriving stock (Show)--instance Exception WorkflowRotate---- ------------------------------------------------------------------------------ Running--- -----------------------------------------------------------------------------{- | Process-wide count of workflow runs currently in flight, backing the-@keiro.workflow.active@ gauge (EP-44). 'runWorkflowWith' brackets each run with-@+1@/@-1@ and samples the gauge on both edges, so the exported last-value-reflects the true live count whether a run is mid-flight or finished. A-process-global 'IORef' is the lightest faithful implementation (the gauge is a-last-value-wins level, not a per-run delta), mirroring how the other keiro-backlog/level gauges are recorded with a value the runtime already holds.--}-{-# NOINLINE activeCountRef #-}-activeCountRef :: IORef Int64-activeCountRef = unsafePerformIO (newIORef 0)--{- | Run a workflow computation, journaling each 'step' and replaying any-already-journaled steps. Returns 'Completed' when the computation finishes-(a 'WorkflowCompleted' marker is journaled) or 'Suspended' when it pauses at-an unresolved 'awaitStep'.--Equivalent to @'runWorkflowWith' 'defaultWorkflowRunOptions'@.--}-runWorkflow ::-    (IOE :> es, Store :> es, Error StoreError :> es) =>-    WorkflowName ->-    WorkflowId ->-    Eff (Workflow : es) a ->-    Eff es (WorkflowOutcome a)-runWorkflow = runWorkflowWith defaultWorkflowRunOptions--{- | 'runWorkflow' with explicit 'WorkflowRunOptions'. This is the single-canonical run entry point; EP-42's resume worker re-invokes through it so-resumed runs honor the same options.--If the workflow's journal already carries a 'WorkflowCancelled' marker (a child-cancelled by its parent, EP-43), the run short-circuits immediately and returns-'Cancelled' without executing any step. The handler also re-checks that marker-on step/await/patch miss paths and after a fresh step action returns, so a-mid-run cancellation stops at the next workflow boundary. A cancellation that-lands after the check but before/during the user action may still let that one-action run; durable workflow steps remain at-least-once at boundaries. If the-journal carries a 'WorkflowFailed' marker, the run likewise short-circuits to-'Failed'. To /propagate/ a finished child's result to its parent, drive the-child through 'Keiro.Workflow.Child.runChildWorkflow' rather than this function-directly.--}-runWorkflowWith ::-    forall a es.-    (IOE :> es, Store :> es, Error StoreError :> es) =>-    WorkflowRunOptions ->-    WorkflowName ->-    WorkflowId ->-    Eff (Workflow : es) a ->-    Eff es (WorkflowOutcome a)-runWorkflowWith options name wid action = do-    -- EP-48: resolve the CURRENT (highest) generation once per run and operate-    -- only on it. A never-rotating workflow stays at generation 0, so naming,-    -- load, and append are byte-for-byte as before. A rotated workflow resolves-    -- to its newest generation, so discovery/resume transparently continue there.-    gen <- currentGeneration name wid-    -- Cancellation short-circuit (EP-43): a workflow whose journal carries a-    -- WorkflowCancelled marker makes no further progress. The index row for that-    -- marker is keyed under 'cancelledStepName' on the current generation, so a-    -- single existence check is enough and we never run the user action.-    cancelled <- stepExists name wid gen cancelledStepName-    failed <- stepExists name wid gen failedStepName-    case (cancelled, failed) of-        (True, _) -> pure Cancelled-        (_, True) -> pure Failed-        _ -> runActive gen-  where-    -- EP-44 telemetry handles, pulled from the run options once. Both default-    -- to 'Nothing' (see 'defaultWorkflowRunOptions'), so a default-options run-    -- records nothing and opens no span — the no-op idiom holds end to end.-    mMetrics = options ^. #metrics-    mTracer = options ^. #tracer-    runActive :: Int -> Eff es (WorkflowOutcome a)-    runActive gen =-        -- EP-44: maintain the process-wide live-run count and sample the-        -- @keiro.workflow.active@ gauge on both entry and exit, and open the-        -- whole-run @workflow \<name\>@ span (step 'Nothing'). The body is-        -- unchanged from EP-41 except for the journal-length recording below.-        bracket_-            (liftIO (atomicModifyIORef' activeCountRef (\n -> (n + 1, ()))) >> sampleActive)-            (liftIO (atomicModifyIORef' activeCountRef (\n -> (n - 1, ()))) >> sampleActive)-            (withWorkflowSpan mTracer name wid Nothing (\_sp -> interpreted))-      where-        sampleActive = liftIO (readIORef activeCountRef) >>= recordWorkflowActive mMetrics-        interpreted = do-            initial <- loadJournal options name wid gen-            initial' <- recordPatchSetIfFresh gen initial-            journalRef <- liftIO (newIORef initial')-            ordinalRef <- liftIO (newIORef Map.empty)-            let runHandler = interpret (handler gen journalRef ordinalRef) action-            outcome <--                (Completed <$> runHandler)-                    `catch` (\WorkflowSuspend -> pure Suspended)-                    `catch` (\WorkflowCancelPending -> pure Cancelled)-                    `catch` ( \(WorkflowRotate seedJson) ->-                                rotateGeneration-                                    mMetrics-                                    (options ^. #activePatches)-                                    name-                                    wid-                                    gen-                                    seedJson-                            )-            case outcome of-                Completed result -> do-                    now <- liftIO getCurrentTime-                    finalMap <- liftIO (readIORef journalRef)-                    -- Idempotent: only appends (and so only snapshots) when the completion-                    -- marker is not already journaled. On a replay of an already-completed-                    -- workflow this is 'Nothing' and no terminal snapshot is taken (one was-                    -- already taken on the original completing run, if the policy fired).-                    mAppend <- appendCompletion name wid gen now-                    for_ mAppend $ \appendResult ->-                        when-                            ( shouldSnapshot-                                (options ^. #snapshotPolicy)-                                Terminal-                                finalMap-                                (appendResult ^. #streamVersion)-                            )-                            (writeWorkflowSnapshotAdvisory mMetrics (appendResult ^. #streamId) (appendResult ^. #streamVersion) finalMap)-                    -- EP-44: record one @keiro.workflow.journal.length@ observation per-                    -- completing run (the 'Completed' path only, never 'Suspended'),-                    -- including a replay that completes again. Length is the recorded-                    -- step map plus the WorkflowCompleted marker.-                    recordWorkflowJournalLength mMetrics (fromIntegral (Map.size finalMap + 1))-                    pure (Completed result)-                Suspended -> markInstanceSuspended name wid >> pure Suspended-                Cancelled -> pure Cancelled-                Failed -> pure Failed-                -- EP-48: the run unwound via 'WorkflowRotate'; 'rotateGeneration'-                -- already journaled the seed step on the next generation and the-                -- rotation marker on this one, so there is nothing more to do here.-                ContinuedAsNew -> pure ContinuedAsNew-        -- Generation 0 has no rotation moment at which to record the patch set,-        -- so it retains the fresh-journal path. Rotated generations receive the-        -- set atomically with their seed in 'rotateGeneration'; this fallback-        -- also keeps generations produced by a pre-change worker compatible.-        recordPatchSetIfFresh runGen initial = do-            let patches = options ^. #activePatches-                freshStart = Map.keysSet initial `Set.isSubsetOf` Set.singleton continueSeedStepName-            if freshStart && not (Set.null patches)-                then do-                    let encoded = Aeson.toJSON (map unPatchId (Set.toList patches))-                    now <- liftIO getCurrentTime-                    appendJournal name wid runGen (StepRecorded patchSetStepName encoded now) >>= \case-                        JournalAppended{} -> pure (Map.insert patchSetStepName encoded initial)-                        JournalAlreadyPresent stored -> pure (Map.insert patchSetStepName stored initial)-                        JournalAppendConflict err -> throwIO (WorkflowJournalAppendError (Text.pack (show err)))-                else pure initial-    handler ::-        Int ->-        IORef (Map Text Aeson.Value) ->-        IORef (Map Text Int) ->-        EffectHandler Workflow es-    handler gen journalRef ordinalRef env operation = case operation of-        Step (StepName key) act -> do-            journal <- liftIO (readIORef journalRef)-            case Map.lookup key journal of-                Just stored -> do-                    -- Hit: the step is already journaled, so its recorded result is-                    -- returned without re-running @act@ — a replay.-                    recordWorkflowStepReplayed mMetrics 1-                    decodeStored key stored-                Nothing -> do-                    renewLease-                    checkCancellationPending name wid gen-                    a <- localSeqUnlift env (\unlift -> unlift act)-                    checkCancellationPending name wid gen-                    let encoded = Aeson.toJSON a-                    now <- liftIO getCurrentTime-                    appendOutcome <- appendJournal name wid gen (StepRecorded key encoded now)-                    case appendOutcome of-                        JournalAppended appendResult -> do-                            -- Miss: @act@ ran and was journaled — a fresh execution.-                            recordWorkflowStepExecuted mMetrics 1-                            newMap <--                                liftIO-                                    ( atomicModifyIORef' journalRef $ \m ->-                                        let m' = Map.insert key encoded m in (m', m')-                                    )-                            -- Evaluate the snapshot policy on the post-append map and version;-                            -- a step is never the terminal marker, hence @False@.-                            when-                                ( shouldSnapshot-                                    (options ^. #snapshotPolicy)-                                    NotTerminal-                                    newMap-                                    (appendResult ^. #streamVersion)-                                )-                                (writeWorkflowSnapshotAdvisory mMetrics (appendResult ^. #streamId) (appendResult ^. #streamVersion) newMap)-                            decodeStored key encoded-                        JournalAlreadyPresent stored -> do-                            liftIO-                                ( atomicModifyIORef' journalRef $ \m ->-                                    (Map.insert key stored m, ())-                                )-                            decodeStored key stored-                        JournalAppendConflict err ->-                            throwIO (WorkflowJournalAppendError (Text.pack (show err)))-        Await (StepName key) arm -> do-            journal <- liftIO (readIORef journalRef)-            case Map.lookup key journal of-                Just stored -> do-                    -- An awaitStep hit means the wake source already resolved this step;-                    -- the recorded result is returned without arming — a replay. An-                    -- awaitStep miss arms and suspends: no user @action@ ran, so it is-                    -- not a step execution and records nothing here.-                    recordWorkflowStepReplayed mMetrics 1-                    decodeStored key stored-                Nothing ->-                    -- The in-memory map can omit a wake completion journaled-                    -- while a snapshotting run was mid-flight. The step index-                    -- is written transactionally with every append, so consult-                    -- it before arming and suspending.-                    lookupStepResult name wid gen key >>= \case-                        Just stored -> do-                            liftIO-                                ( atomicModifyIORef' journalRef $ \m ->-                                    (Map.insert key stored m, ())-                                )-                            recordWorkflowStepReplayed mMetrics 1-                            decodeStored key stored-                        Nothing -> do-                            renewLease-                            checkCancellationPending name wid gen-                            localSeqUnlift env (\unlift -> unlift arm)-                            throwIO WorkflowSuspend-        CurrentWorkflow -> pure (name, wid)-        CurrentRunGeneration -> pure gen-        FreshOrdinal namespace ->-            liftIO . atomicModifyIORef' ordinalRef $ \counters ->-                let n = Map.findWithDefault 0 namespace counters-                 in (Map.insert namespace (n + 1) counters, n)-        -- EP-48: encode the carried seed and throw the rotation sentinel, which-        -- 'runWorkflowWith' catches and turns into 'rotateGeneration'. Never-        -- returns to the caller within this run (result type is polymorphic).-        ContinueAsNew seed -> throwIO (WorkflowRotate (Aeson.toJSON seed))-        -- EP-49: decide and journal a cross-cutting branch. Mirrors the 'Step'-        -- hit/miss shape, but the miss path computes the decision from the-        -- patch set recorded when this workflow generation first started.-        Patch pid -> do-            let key = patchStepName pid-            journal <- liftIO (readIORef journalRef)-            case Map.lookup key journal of-                Just stored ->-                    -- Hit: the decision was made on an earlier run; replay it verbatim.-                    decodeStored key stored-                Nothing -> do-                    checkCancellationPending name wid gen-                    recordedSet <- case Map.lookup patchSetStepName journal of-                        Nothing -> pure []-                        Just stored -> decodeStored patchSetStepName stored-                    let decision = unPatchId pid `elem` (recordedSet :: [Text])-                        encoded = Aeson.toJSON decision-                    now <- liftIO getCurrentTime-                    appendOutcome <- appendJournal name wid gen (StepRecorded key encoded now)-                    case appendOutcome of-                        JournalAppended{} -> do-                            liftIO-                                ( atomicModifyIORef' journalRef $ \m ->-                                    (Map.insert key encoded m, ())-                                )-                            pure decision-                        JournalAlreadyPresent stored -> do-                            liftIO-                                ( atomicModifyIORef' journalRef $ \m ->-                                    (Map.insert key stored m, ())-                                )-                            decodeStored key stored-                        JournalAppendConflict err ->-                            throwIO (WorkflowJournalAppendError (Text.pack (show err)))-      where-        renewLease =-            for_ (options ^. #leaseHeartbeat) $ \heartbeat -> do-                renewed <--                    renewInstanceLease-                        (heartbeat ^. #owner)-                        (heartbeat ^. #ttl)-                        name-                        wid-                unless renewed (throwIO WorkflowLeaseLost)---- | Decode a stored journal result into the type the caller expects.-decodeStored :: (Aeson.FromJSON a) => Text -> Aeson.Value -> Eff es a-decodeStored key stored = case Aeson.fromJSON stored of-    Aeson.Success a -> pure a-    Aeson.Error message -> throwIO (WorkflowStepDecodeError key (Text.pack message))--checkCancellationPending :: (Store :> es) => WorkflowName -> WorkflowId -> Int -> Eff es ()-checkCancellationPending name wid gen = do-    cancelled <- stepExists name wid gen cancelledStepName-    when cancelled (throwIO WorkflowCancelPending)--{- | Pre-load a workflow's journal stream into a @step name -> result@ map.--If a compatible snapshot exists ('loadWorkflowSnapshot'), seed the map from it-and read only the journal events /after/ the snapshot's version ("tail-replay"). The reconstructed map is the journal state as the snapshotting run-saw it. A wake completion journaled concurrently with that run can fall at or-before the snapshot version yet be absent from the seed, so the map may-under-approximate the journal. The @Await@ handler compensates by consulting-the authoritative @keiro_workflow_steps@ index on a map miss; that index is-written transactionally with every journal append.--A missing, mismatched, or undecodable snapshot is recorded as a miss (and, for-undecodable bytes, a decode failure) before the read falls back to a full-replay from version 0.-'WorkflowCompleted' contributes nothing to the map.--}-loadJournal ::-    (IOE :> es, Store :> es) =>-    WorkflowRunOptions ->-    WorkflowName ->-    WorkflowId ->-    Int ->-    Eff es (Map Text Aeson.Value)-loadJournal options name wid gen = do-    let journalName = workflowGenerationStreamName name wid gen-    snapshot <- lookupWorkflowSnapshot journalName-    (seedMap, fromVersion) <- case snapshot of-        Right (m, v) -> do-            recordSnapshotReadHits (options ^. #metrics) 1-            pure (m, v)-        Left reason -> do-            recordSnapshotReadMisses (options ^. #metrics) 1-            case reason of-                SnapshotDecodeFailed _ -> recordSnapshotDecodeFailures (options ^. #metrics) 1-                _ -> pure ()-            pure (Map.empty, StreamVersion 0)-    let-        events = readStreamForwardStream journalName fromVersion (options ^. #pageSize)-    Streamly.fold (Fold.foldlM' accumulate (pure seedMap)) events-  where-    accumulate journal recorded =-        case decodeRecorded workflowJournalCodec recorded of-            Right (StepRecorded key value _) -> pure (Map.insert key value journal)-            Right (WorkflowCompleted _) -> pure journal-            Right (WorkflowCancelled _) -> pure journal-            Right (WorkflowFailed _ _) -> pure journal-            Right (WorkflowContinuedAsNew _ _) -> pure journal -- a rotation marker carries no step result-            Left err -> throwIO (WorkflowJournalDecodeError (Text.pack (show err)))---- ------------------------------------------------------------------------------ Journal append helpers--- -----------------------------------------------------------------------------data JournalAppendOutcome-    = JournalAppended !AppendResult-    | JournalAlreadyPresent !Aeson.Value-    | JournalAppendConflict !AppendConflict-    deriving stock (Eq, Show)--prepareJournalAppend ::-    (IOE :> es) =>-    WorkflowName ->-    WorkflowId ->-    Int ->-    WorkflowJournalEvent ->-    Eff es (Tx.Transaction JournalAppendOutcome)-prepareJournalAppend name wid gen event = do-    let key = journalKey event-        entryId = deterministicJournalId name wid gen key-        requestedEntryId = case event of-            -- Resurrection removes the derived failure-marker index row while-            -- retaining append-only journal history. A later failure on the-            -- same generation therefore needs a fresh UUIDv7; step locking and-            -- the in-transaction index check still deduplicate concurrent-            -- failure writers.-            WorkflowFailed{} -> Nothing-            _ -> Just entryId-        row = journalRow name wid gen event-        (status, mLastError) = instanceStatusForEvent event-        journalName = workflowGenerationStreamName name wid gen-        lockKey =-            Text.intercalate-                "/"-                [unWorkflowId wid, unWorkflowName name, Text.pack (show gen), key]-    base <- case encodeForAppendWithMetadata workflowJournalCodec Nothing event of-        Right encoded -> pure encoded-        Left err -> throwIO (WorkflowJournalEncodeError (Text.pack (show err)))-    let entry = base & #eventId .~ requestedEntryId :: EventData-    prepared <- prepareEventsIO [entry]-    now <- liftIO getCurrentTime-    pure $ do-        lockWorkflowStepTx lockKey-        lookupStepResultTx (unWorkflowId wid) (unWorkflowName name) gen key >>= \case-            Just stored -> pure (JournalAlreadyPresent stored)-            Nothing ->-                appendToStreamTx journalName AnyVersion prepared now >>= \case-                    Left err -> pure (JournalAppendConflict err)-                    Right appendResult ->-                        JournalAppended appendResult-                            <$ recordStepTx row-                            <* upsertInstanceTx-                                (unWorkflowId wid)-                                (unWorkflowName name)-                                (fromIntegral gen)-                                status-                                mLastError--appendJournal :: (IOE :> es, Store :> es) => WorkflowName -> WorkflowId -> Int -> WorkflowJournalEvent -> Eff es JournalAppendOutcome-appendJournal name wid gen event =-    prepareJournalAppend name wid gen event >>= runTransaction--{- | Append a journal event to a workflow's journal stream (and keep its-index row consistent), idempotently. If the entry already exists this is a-no-op returning the would-be event id.--This is the integration helper a wake source's external-completion path uses-to record an awaited step's resolution. The append uses a deterministic event-id derived from @("keiro" : "workflow" : name : id : stepName)@ so concurrent-or retried writes collapse to one row.--}-appendJournalEntry :: (IOE :> es, Store :> es) => WorkflowName -> WorkflowId -> WorkflowJournalEvent -> Eff es ()-appendJournalEntry name wid event = void (appendJournalEntryReturningId name wid event)--{- | Like 'appendJournalEntry' but returns the (deterministic) 'EventId' of-the entry. EP-39's fired timer needs this for @markTimerFired@.--}-appendJournalEntryReturningId :: (IOE :> es, Store :> es) => WorkflowName -> WorkflowId -> WorkflowJournalEvent -> Eff es EventId-appendJournalEntryReturningId name wid event = do-    -- EP-48: a wake source (timer fired, signalAwakeable, child completion)-    -- resolves the awaited step on whichever generation the suspended run is-    -- parked on — always the current (highest) one, since runs only ever operate-    -- on the current generation. Resolve it here so the append and its-    -- deterministic id are namespaced by that generation.-    gen <- currentGeneration name wid-    let key = journalKey event-        entryId = deterministicJournalId name wid gen key-    appendJournal name wid gen event >>= \case-        JournalAppended{} -> pure entryId-        JournalAlreadyPresent{} -> pure entryId-        JournalAppendConflict err -> throwIO (WorkflowJournalAppendError (Text.pack (show err)))--{- | Append a journal entry only if it is not already journaled, returning the-'AppendResult' of the fresh append (or 'Nothing' if it already existed). Used-on the completion path so a terminal ('OnTerminal') snapshot can be taken from-the completing run's 'AppendResult', while a replay of an already-completed-workflow is a no-op.--}-appendCompletion :: (IOE :> es, Store :> es) => WorkflowName -> WorkflowId -> Int -> UTCTime -> Eff es (Maybe AppendResult)-appendCompletion name wid gen now = do-    appendJournal name wid gen (WorkflowCompleted now) >>= \case-        JournalAppended appendResult -> pure (Just appendResult)-        JournalAlreadyPresent{} -> pure Nothing-        JournalAppendConflict err -> throwIO (WorkflowJournalAppendError (Text.pack (show err)))--{- | Perform a continue-as-new rotation (EP-48): close generation @gen@ and open-generation @gen + 1@, seeded with @seedJson@ and the deployed patch set. Returns-'ContinuedAsNew'.--The next generation's seed and non-empty patch set are appended in one-transaction before the old generation's rotation marker. The seed advances-@MAX(generation)@ — and therefore 'currentGeneration' — to @gen + 1@, while the-same commit makes patch decisions available before any asynchronous wake writer-can append to the new generation. After that commit, any re-run resolves the-current generation to @gen + 1@, hydrates from the seed and patch set, and never-re-enters generation @gen@. We then append the terminal-'WorkflowContinuedAsNew' marker on generation @gen@. Every append is guarded by-an existence check and uses a deterministic, generation-namespaced id, so the-whole rotation is idempotent.--The seed carries state forward and the patch-set entry freezes code-evolution-decisions. We snapshot their map at the newest fresh append's version so the-next generation hydrates in O(1). The snapshot is advisory, so it is written-unconditionally on rotation regardless of the run's 'snapshotPolicy' — rotation-is exactly when a fresh snapshot earns its keep.--}-rotateGeneration ::-    forall a es.-    (IOE :> es, Store :> es, Error StoreError :> es) =>-    Maybe KeiroMetrics ->-    Set PatchId ->-    WorkflowName ->-    WorkflowId ->-    Int ->-    Aeson.Value ->-    Eff es (WorkflowOutcome a)-rotateGeneration mMetrics patches name wid gen seedJson = do-    let nextGen = gen + 1-        encodedPatches = Aeson.toJSON (map unPatchId (Set.toList patches))-        patchEvent =-            StepRecorded patchSetStepName encodedPatches-    now <- liftIO getCurrentTime-    seedTx <--        prepareJournalAppend-            name-            wid-            nextGen-            (StepRecorded continueSeedStepName seedJson now)-    patchTx <--        if Set.null patches-            then pure Nothing-            else-                Just-                    <$> prepareJournalAppend-                        name-                        wid-                        nextGen-                        (patchEvent now)-    -- 1. Seed and patch set on the NEXT generation in one transaction. A-    -- conflict condemns the whole transaction before it returns its diagnostic-    -- outcome, so no seed-without-patch intermediate state can commit.-    (seedOutcome, patchOutcome) <--        runTransaction $ do-            seedResult <- seedTx-            condemnOnConflict seedResult-            patchResult <- traverse id patchTx-            traverse_ condemnOnConflict patchResult-            pure (seedResult, patchResult)-    throwOnConflict seedOutcome-    traverse_ throwOnConflict patchOutcome-    let seedValue = recordedValue seedJson seedOutcome-        snapshotState =-            maybe-                (Map.singleton continueSeedStepName seedValue)-                ( \outcome ->-                    Map.fromList-                        [ (continueSeedStepName, seedValue)-                        , (patchSetStepName, recordedValue encodedPatches outcome)-                        ]-                )-                patchOutcome-        snapshotAppend =-            case patchOutcome of-                Just (JournalAppended appendResult) -> Just appendResult-                _ -> case seedOutcome of-                    JournalAppended appendResult -> Just appendResult-                    _ -> Nothing-    for_ snapshotAppend $ \appendResult ->-        writeWorkflowSnapshotAdvisory-            mMetrics-            (appendResult ^. #streamId)-            (appendResult ^. #streamVersion)-            snapshotState-    -- 2. Terminal rotation marker on the CURRENT generation (audit + closes it).-    appendJournal name wid gen (WorkflowContinuedAsNew nextGen now) >>= \case-        JournalAppended{} -> pure ()-        JournalAlreadyPresent{} -> pure ()-        JournalAppendConflict err -> throwIO (WorkflowJournalAppendError (Text.pack (show err)))-    pure ContinuedAsNew-  where-    condemnOnConflict = \case-        JournalAppendConflict{} -> Tx.condemn-        _ -> pure ()-    throwOnConflict = \case-        JournalAppendConflict err ->-            throwIO (WorkflowJournalAppendError (Text.pack (show err)))-        _ -> pure ()-    recordedValue fallback = \case-        JournalAlreadyPresent stored -> stored-        _ -> fallback--{- | Snapshot a workflow state after its journal append has committed. The-snapshot is advisory: a store failure is counted and cannot turn the-already-durable workflow transition into a failed run.--}-writeWorkflowSnapshotAdvisory ::-    (IOE :> es, Store :> es, Error StoreError :> es) =>-    Maybe KeiroMetrics ->-    StreamId ->-    StreamVersion ->-    WorkflowState ->-    Eff es ()-writeWorkflowSnapshotAdvisory mMetrics streamId version state = do-    -- WorkflowState is already a Map Text Value assembled from journaled step-    -- results, so this path has no aggregate RegFile/uninit encode to guard.-    outcome <- tryError @StoreError (writeWorkflowSnapshot streamId version state)-    case outcome of-        Right () -> pure ()-        Left _ -> recordSnapshotWriteFailures mMetrics 1--instanceStatusForEvent :: WorkflowJournalEvent -> (WorkflowStatus, Maybe Text)-instanceStatusForEvent = \case-    StepRecorded{} -> (WfRunning, Nothing)-    WorkflowCompleted{} -> (WfCompleted, Nothing)-    WorkflowCancelled{} -> (WfCancelled, Nothing)-    WorkflowFailed reason _ -> (WfFailed, Just reason)-    WorkflowContinuedAsNew{} -> (WfRunning, Nothing)---- | The reserved step-name key a journal event indexes under.-journalKey :: WorkflowJournalEvent -> Text-journalKey = \case-    StepRecorded{stepName = key} -> key-    WorkflowCompleted{} -> completedStepName-    WorkflowCancelled{} -> cancelledStepName-    WorkflowFailed{} -> failedStepName-    WorkflowContinuedAsNew{} -> continuedAsNewStepName---- | The index row corresponding to a journal event, on the given generation.-journalRow :: WorkflowName -> WorkflowId -> Int -> WorkflowJournalEvent -> WorkflowStepRow-journalRow name wid gen = \case-    StepRecorded key value t ->-        WorkflowStepRow-            { workflowId = unWorkflowId wid-            , workflowName = unWorkflowName name-            , generation = gen-            , stepName = key-            , result = value-            , recordedAt = t-            }-    WorkflowCompleted t ->-        WorkflowStepRow-            { workflowId = unWorkflowId wid-            , workflowName = unWorkflowName name-            , generation = gen-            , stepName = completedStepName-            , result = Aeson.Null-            , recordedAt = t-            }-    WorkflowCancelled t ->-        WorkflowStepRow-            { workflowId = unWorkflowId wid-            , workflowName = unWorkflowName name-            , generation = gen-            , stepName = cancelledStepName-            , result = Aeson.Null-            , recordedAt = t-            }-    WorkflowFailed r t ->-        WorkflowStepRow-            { workflowId = unWorkflowId wid-            , workflowName = unWorkflowName name-            , generation = gen-            , stepName = failedStepName-            , result = Aeson.toJSON r-            , recordedAt = t-            }-    WorkflowContinuedAsNew g t ->-        WorkflowStepRow-            { workflowId = unWorkflowId wid-            , workflowName = unWorkflowName name-            , generation = gen-            , stepName = continuedAsNewStepName-            , result = Aeson.toJSON g -- the NEXT generation this rotation opens-            , recordedAt = t-            }--{- | A stable, collision-resistant journal-event id from-@("keiro" : "workflow" : name : id : generation : stepName)@ via a v5 UUID.-Mirrors 'Keiro.ProcessManager.deterministicCommandId': the same inputs always-yield the same id, so a re-append of the same step collapses to the same row.--The /generation/ (EP-48) is part of the id so a step named @"s1"@ in-generation 0 and the same name in generation 1 produce __different__ kiroku-event ids — they live on different physical streams, but the event id is-global, so namespacing it by generation keeps rotated generations from-colliding on the deterministic id.--}-deterministicJournalId :: WorkflowName -> WorkflowId -> Int -> Text -> EventId-deterministicJournalId (WorkflowName name) (WorkflowId wid) gen key =-    EventId $-        UUID.V5.generateNamed UUID.V5.namespaceURL $-            fmap (fromIntegral . fromEnum) $-                Text.unpack $-                    Text.intercalate ":" ["keiro", "workflow", name, wid, Text.pack (show gen), key]+-- | The durable workflow runtime: the @Workflow@ effect, named-step+-- journaling, replay, and suspension.+--+-- == What this gives you+--+-- Write a long-running process as an ordinary @effectful@ computation and run+-- it with 'runWorkflow'. Each @'step' name action@ either runs @action@ and+-- records ("journals") its result, or — on a replay after a crash — returns the+-- previously recorded result /without/ re-running the side effect. The journal+-- is a kiroku stream named @wf:\<name\>-\<id\>@ ('workflowStreamName'); there is+-- no separate history table. Because a workflow can pause (waiting for a timer,+-- an external signal, or a child), 'runWorkflow' returns a 'WorkflowOutcome'+-- ('Completed' or 'Suspended').+--+-- Step side effects are at-least-once across process crashes. If the process+-- crashes after @action@ runs but before the journal append commits, a later+-- resume has no record of that step and runs @action@ again. Step bodies that call+-- external systems must therefore be idempotent, typically by deriving an+-- idempotency key from the workflow identity and step name and passing it to the+-- external system.+--+-- Replay is keyed by step name, not by source position or code identity. Renaming+-- a step intentionally orphans the old journal entry and runs the renamed step as+-- new work; changing the meaning of a step while keeping the same name is the+-- author's responsibility. Use 'patch' for cross-cutting workflow-body changes+-- that need an explicit old/new branch.+--+-- == Contract recap for downstream plans (the v2 MasterPlan)+--+-- * The authoring surface is the @Workflow@ effect with 'step', 'awaitStep',+--   'currentWorkflow', and 'freshOrdinal'. Add new primitives (sleep,+--   awakeable, child) as functions that go /through/ this effect so a single+--   import stays the workflow surface.+-- * 'awaitStep' is the suspension primitive every wake source builds on: it+--   returns a journaled result if present, otherwise runs an idempotent+--   /arming/ action once and suspends the run. The arming action MUST be+--   idempotent — a suspended-then-resumed workflow re-enters 'awaitStep' from+--   the top on every resume until the result is journaled, so it re-runs @arm@+--   each time (e.g. schedule a timer with a deterministic id so repeats+--   collapse to a no-op).+-- * A wake source's external completion path (a timer firing,+--   @signalAwakeable@, a child finishing) calls 'appendJournalEntry' (or+--   'appendJournalEntryReturningId') with a 'StepRecorded' whose @stepName@ is+--   the awaited step name; the next 'runWorkflow' then takes the 'awaitStep'+--   hit path and proceeds.+-- * The journal codec ('workflowJournalCodec') and the reserved step-name+--   prefixes ('sleepStepPrefix' = @"sleep:"@, 'awakeableStepPrefix' = @"awk:"@,+--   'childStepPrefix' = @"child:"@) are integration contracts: suspensions are+--   journaled as ordinary 'StepRecorded' events with these prefixes, never as+--   new event types, so the replay loop stays uniform.+-- * Per-run options live in one record, 'WorkflowRunOptions' (EP-41 adds a+--   snapshot policy, EP-44 adds metrics/tracer); 'runWorkflowWith' is the+--   single canonical entry EP-42's resume worker re-invokes through.+-- * The derived @keiro_workflows@ instance row is maintained by journal append+--   transactions. Terminal markers ('WorkflowCompleted', 'WorkflowCancelled',+--   'WorkflowFailed') freeze the instance as completed/cancelled/failed, and the+--   resume worker uses its attempt/lease fields for crash recovery.+-- * Discovery (EP-42) is 'findUnfinishedWorkflowIds' plus 'completedStepName';+--   it needs no kiroku prefix subscription.+--+-- > __Build gotcha__ (EP-38's migration adds @keiro_workflow_steps@): adding a+-- > new @.sql@ file under @keiro-migrations/sql-migrations/@ does not trigger+-- > recompilation of @Keiro.Migrations@ (cabal says "Up to date" even with+-- > @-fforce-recomp@, because @embedDir@ is a Template Haskell directory read+-- > GHC's recompilation checker does not track per-file). After adding a+-- > migration, edit a comment in @keiro-migrations/src/Keiro/Migrations.hs@ or+-- > run @cabal clean@ before building.+module Keiro.Workflow+  ( -- * The effect and authoring surface+    Workflow,+    step,+    awaitStep,+    currentWorkflow,+    currentRunGeneration,+    freshOrdinal,+    continueAsNew,+    restoreSeed,+    patch,++    -- * Running a workflow+    runWorkflow,+    runWorkflowWith,+    WorkflowRunOptions (..),+    LeaseHeartbeat (..),+    defaultWorkflowRunOptions,++    -- * Journal append helpers (used by wake-source plans)+    JournalAppendOutcome (..),+    prepareJournalAppend,+    appendJournalEntry,+    appendJournalEntryReturningId,+    deterministicJournalId,++    -- * Errors thrown by the runtime+    WorkflowError (..),+    WorkflowLeaseLost (..),++    -- * Re-exported core contracts+    module Keiro.Workflow.Types,+    WorkflowStepRow (..),+    recordStepTx,+    loadStepIndex,+    stepExists,+    currentGeneration,+    findUnfinishedWorkflowIds,+    setWorkflowWakeAfterTx,+    clearWorkflowWakeAfterTx,+  )+where++import Control.Exception (Exception)+import Data.Aeson qualified as Aeson+import Data.IORef+  ( IORef,+    atomicModifyIORef',+    newIORef,+    readIORef,+  )+import Data.Int (Int32)+import Data.Map.Strict (Map)+import Data.Map.Strict qualified as Map+import Data.Set (Set)+import Data.Set qualified as Set+import Data.Text qualified as Text+import Data.Time (NominalDiffTime)+import Data.UUID.V5 qualified as UUID.V5+import Effectful (Dispatch (..), DispatchOf, Eff, Effect, IOE, (:>))+import Effectful.Dispatch.Dynamic (EffectHandler, interpret, localSeqUnlift, send)+import Effectful.Error.Static (Error, tryError)+import Effectful.Exception (bracket_, catch, throwIO)+import Keiro.Codec (decodeRecorded, encodeForAppendWithMetadata)+import Keiro.EventStream (SnapshotPolicy (..), Terminality (..))+import Keiro.Prelude+import Keiro.Snapshot (SnapshotMissReason (..))+import Keiro.Snapshot.Policy (shouldSnapshot)+import Keiro.Telemetry+  ( KeiroMetrics,+    Tracer,+    recordSnapshotDecodeFailures,+    recordSnapshotReadHits,+    recordSnapshotReadMisses,+    recordSnapshotWriteFailures,+    recordWorkflowActive,+    recordWorkflowJournalLength,+    recordWorkflowStepExecuted,+    recordWorkflowStepReplayed,+    withWorkflowSpan,+  )+import Keiro.Workflow.Instance+  ( WorkflowStatus (..),+    markInstanceSuspended,+    renewInstanceLease,+    upsertInstanceTx,+  )+import Keiro.Workflow.Schema (WorkflowStepRow (..), clearWorkflowWakeAfterTx, currentGeneration, findUnfinishedWorkflowIds, loadStepIndex, lockWorkflowStepTx, lookupStepResult, lookupStepResultTx, recordStepTx, setWorkflowWakeAfterTx, stepExists)+import Keiro.Workflow.Snapshot (lookupWorkflowSnapshot, writeWorkflowSnapshot)+import Keiro.Workflow.Types+import Kiroku.Store.Effect (Store)+import Kiroku.Store.Error (StoreError)+import Kiroku.Store.Read (readStreamForwardStream)+import Kiroku.Store.Transaction (AppendConflict, appendToStreamTx, prepareEventsIO, runTransaction)+import Kiroku.Store.Types (AppendResult (..), EventData, EventId (..), ExpectedVersion (..), StreamId, StreamVersion (..))+import Streamly.Data.Fold qualified as Fold+import Streamly.Data.Stream qualified as Streamly+import System.IO.Unsafe (unsafePerformIO)+import "hasql-transaction" Hasql.Transaction qualified as Tx++-- ---------------------------------------------------------------------------+-- The effect+-- ---------------------------------------------------------------------------++-- | The durable workflow effect. Its operations are interpreted by+-- 'runWorkflow' / 'runWorkflowWith', which journal and replay them.+data Workflow :: Effect where+  -- | Run a side-effecting action under a name, journaling its result; on+  --     replay, return the recorded result without re-running the action.+  Step :: (Aeson.ToJSON a, Aeson.FromJSON a) => StepName -> m a -> Workflow m a+  -- | Return the awaited step's journaled result, or run the (idempotent)+  --     arming action once and suspend the run.+  Await :: (Aeson.FromJSON a) => StepName -> m () -> Workflow m a+  -- | The running workflow's identity (for keying wake sources).+  CurrentWorkflow :: Workflow m (WorkflowName, WorkflowId)+  -- | The journal generation this run is operating on.+  CurrentRunGeneration :: Workflow m Int+  -- | A per-run, per-namespace counter for deterministic ordinal step names.+  FreshOrdinal :: Text -> Workflow m Int+  -- | EP-48: snapshot the carried seed, rotate onto a fresh journal generation,+  --     and unwind this run; the next run/resume continues from the seed. Never+  --     returns to the caller within this run (result type is fully polymorphic).+  ContinueAsNew :: (Aeson.ToJSON s) => s -> Workflow m a+  -- | EP-49: decide and journal a cross-cutting branch — returns the stable+  --     'Bool' branch decision for the given patch. Fresh instances get 'True'+  --     (new branch); instances already in flight when the patch shipped get+  --     'False' (old branch). The decision is journaled on first encounter and+  --     replayed verbatim thereafter.+  Patch :: PatchId -> Workflow m Bool++type instance DispatchOf Workflow = Dynamic++-- | Run @action@ under @name@, journaling its encoded result. On a replay where+-- @name@ is already journaled, the recorded result is returned and @action@ is+-- not run. If the process crashed after @action@ ran but before the journal+-- commit, the action runs again on resume: workflow step side effects are+-- at-least-once at the step boundary.+--+-- The returned value is always the JSON round-trip of the recorded result,+-- including on the first run. A lossy or rejecting @ToJSON@\/@FromJSON@ pair is+-- therefore observed immediately rather than only after a crash and replay.+--+-- Requires @'Aeson.ToJSON' a@ (to journal the result) and @'Aeson.FromJSON' a@+-- (to decode it on replay).+step :: (Workflow :> es, Aeson.ToJSON a, Aeson.FromJSON a) => StepName -> Eff es a -> Eff es a+step name action = send (Step name action)++-- | Look up @name@ in the journal. If a wake source has already recorded its+-- completion (a 'StepRecorded' whose @stepName@ is @name@, carrying the+-- resolved result), decode and return it. Otherwise run @arm@ exactly once+-- (the wake source's idempotent job — schedule a timer, register an awakeable,+-- spawn a child) and __suspend__ this run, so 'runWorkflow' returns 'Suspended'.+--+-- @arm@ must be idempotent: every resume re-runs it until the result is+-- journaled.+awaitStep :: (Workflow :> es, Aeson.FromJSON a) => StepName -> Eff es () -> Eff es a+awaitStep name arm = send (Await name arm)++-- | The identity of the workflow currently running.+currentWorkflow :: (Workflow :> es) => Eff es (WorkflowName, WorkflowId)+currentWorkflow = send CurrentWorkflow++-- | The journal generation this run is operating on. Wake sources include it+-- in their durable identities so a generation opened by 'continueAsNew' never+-- collides with prior-generation rows.+currentRunGeneration :: (Workflow :> es) => Eff es Int+currentRunGeneration = send CurrentRunGeneration++-- | A per-run, per-namespace counter (starting at 0). Used by convenience+-- forms of wake sources (e.g. @sleep@ → @"sleep:0"@) to derive a deterministic,+-- replay-stable ordinal name. Note: ordinal names are only stable if the order+-- of @awaitStep@-style calls does not change across deploys; the named forms+-- are the stable primitives.+freshOrdinal :: (Workflow :> es) => Text -> Eff es Int+freshOrdinal namespace = send (FreshOrdinal namespace)++-- | Continue this workflow /as new/ (EP-48): snapshot the carried @seed@ onto a+-- fresh journal generation, journal a terminal rotation marker on the current+-- generation, and unwind this run. The next run or resume of the same logical+-- @('WorkflowName', 'WorkflowId')@ starts against the fresh generation, hydrated+-- from the seed, with an empty (bounded) journal.+--+-- This is how a workflow that runs an /unbounded/ number of steps — a poller, a+-- per-day rolling process — keeps its per-generation journal bounded so replay+-- and hydration stay fast forever. The result type is fully polymorphic (@a@)+-- because control never returns to the caller within /this/ run: the rotated+-- continuation runs in the next run/resume. Read the carried seed back at the top+-- of the workflow body with 'restoreSeed'.+continueAsNew :: (Workflow :> es, Aeson.ToJSON s) => s -> Eff es a+continueAsNew seed = send (ContinueAsNew seed)++-- | Restore the seed carried by the previous generation's 'continueAsNew', or+-- return @def@ on the first generation (EP-48). Implemented as an ordinary+-- journaled @step@ under the reserved 'continueSeedStepName': on a generation that+-- was rotated into, the seed step was journaled (and snapshotted) by the rotation,+-- so this @step@ hits it and returns the carried value without re-running; on the+-- very first generation it misses and records @def@. Call it once at the top of a+-- workflow body that uses 'continueAsNew'.+restoreSeed :: (Workflow :> es, Aeson.ToJSON s, Aeson.FromJSON s) => s -> Eff es s+restoreSeed def = step (StepName continueSeedStepName) (pure def)++-- | Decide a cross-cutting branch for an in-flight-vs-fresh code change, and+-- journal the decision so every later replay observes the same branch (EP-49).+--+-- @patch (PatchId "fraud-check-v2")@ returns 'True' only when that id was present+-- in 'activePatches' when this workflow generation first started. The generation+-- records its active set under 'patchSetStepName' exactly once; on the first+-- encounter each individual patch decision is journaled under @patch:\<patchId\>@,+-- and every replay returns the recorded 'Bool'. Add a patch id to 'activePatches'+-- in the deploy that introduces the corresponding 'patch' call; remove it only+-- after deleting that call from the workflow body.+--+-- This is an /escape hatch/ for changes that cross-cut multiple steps. For the+-- common case — one step changed — do __not__ use 'patch': rename the step's+-- 'StepName' instead. A renamed step has no journaled history under its new name,+-- so its action runs fresh on the next replay, which is exactly the right+-- behaviour for a single-step change. Reach for 'patch' only when an in-flight+-- instance would be left incoherent by the new code (e.g. the change adds, removes,+-- or reorders steps, or changes the meaning of an already-journaled step result).+patch :: (Workflow :> es) => PatchId -> Eff es Bool+patch pid = send (Patch pid)++-- ---------------------------------------------------------------------------+-- Per-run options+-- ---------------------------------------------------------------------------++-- | Lease renewal coordinates for a resume-worker-owned workflow run.+--+-- The runtime renews this lease immediately before each fresh step action and+-- unresolved await arm. Direct 'runWorkflow' calls leave it 'Nothing'.+data LeaseHeartbeat = LeaseHeartbeat+  { owner :: !Text,+    ttl :: !NominalDiffTime+  }+  deriving stock (Generic, Eq, Show)++-- | Options for a single workflow run. This is the canonical home for+-- per-run options across the v2 initiative — EP-41 adds the snapshot policy,+-- EP-44 adds metrics/tracer fields, all additive. Extend it additively; never+-- break the field set EP-38/EP-41 established.+data WorkflowRunOptions = WorkflowRunOptions+  { -- | When to persist a snapshot of the accumulated step-result map after a+    --     step append (and at completion, for 'OnTerminal'). Default 'Never'+    --     (EP-38 behaviour: every run/resume does a full version-0 replay).+    snapshotPolicy :: !(SnapshotPolicy WorkflowState),+    -- | Page size for the journal pre-load read.+    pageSize :: !Int32,+    -- | EP-44: when 'Just', the runtime records the @keiro.workflow.*@ instruments+    --     (steps executed/replayed, active count, journal length). 'Nothing' is the+    --     no-op default, so a run with 'defaultWorkflowRunOptions' records nothing.+    metrics :: !(Maybe KeiroMetrics),+    -- | EP-44: when 'Just', the runtime opens a @workflow \<name\>@ 'Internal' span+    --     around the run. 'Nothing' runs the body unwrapped.+    tracer :: !(Maybe Tracer),+    -- | Patch ids currently active in this deployed workflow code. A fresh+    --     workflow generation records this set once under 'patchSetStepName', and+    --     each 'patch' call returns 'True' iff its id was in that recorded set.+    activePatches :: !(Set PatchId),+    -- | Resume-worker lease coordinates. When present, fresh workflow+    --     boundaries renew the lease and throw 'WorkflowLeaseLost' if another owner+    --     has taken it. 'Nothing' keeps direct runs free of lease traffic.+    leaseHeartbeat :: !(Maybe LeaseHeartbeat)+  }+  deriving stock (Generic)++-- | Sensible defaults: no snapshotting, a journal pre-load page size of 100,+-- and no telemetry (metrics/tracer 'Nothing'). A default-options run replays+-- and behaves exactly as EP-38 did.+defaultWorkflowRunOptions :: WorkflowRunOptions+defaultWorkflowRunOptions =+  WorkflowRunOptions+    { snapshotPolicy = Never,+      pageSize = 100,+      metrics = Nothing,+      tracer = Nothing,+      activePatches = Set.empty,+      leaseHeartbeat = Nothing+    }++-- ---------------------------------------------------------------------------+-- Errors and the suspension sentinel+-- ---------------------------------------------------------------------------++-- | Errors the workflow runtime raises (via 'throwIO', so they surface+-- through the surrounding store/IO error channel).+data WorkflowError+  = -- | A journaled step result could not be decoded into the type the+    --       replaying @step@/@awaitStep@ expects (step name, decode message). The+    --       result type changed incompatibly — a programmer error.+    WorkflowStepDecodeError !Text !Text+  | -- | A journal event could not be decoded during pre-load.+    WorkflowJournalDecodeError !Text+  | -- | A journal event could not be encoded for append.+    WorkflowJournalEncodeError !Text+  | -- | Appending a journal entry failed for a non-conflict reason.+    WorkflowJournalAppendError !Text+  deriving stock (Eq, Show)++instance Exception WorkflowError++-- | The resume worker no longer owns the workflow instance lease.+--+-- Thrown before a fresh step action or unresolved await arm, so the run stops+-- before performing further side effects. Resume workers classify this as a+-- lease skip rather than a workflow crash.+data WorkflowLeaseLost = WorkflowLeaseLost+  deriving stock (Eq, Show)++instance Exception WorkflowLeaseLost++-- | Internal sentinel thrown to unwind a suspended run up to 'runWorkflowWith'.+data WorkflowSuspend = WorkflowSuspend+  deriving stock (Show)++instance Exception WorkflowSuspend++-- | Internal sentinel thrown when a cancellation marker appears mid-run.+data WorkflowCancelPending = WorkflowCancelPending+  deriving stock (Show)++instance Exception WorkflowCancelPending++-- | Internal sentinel thrown by the 'ContinueAsNew' handler to unwind a+-- rotating run up to 'runWorkflowWith' (EP-48), carrying the JSON-encoded seed for+-- the next generation. Mirrors 'WorkflowSuspend': a non-returning unwind the run+-- entry point catches and turns into an outcome ('ContinuedAsNew').+newtype WorkflowRotate = WorkflowRotate Aeson.Value+  deriving stock (Show)++instance Exception WorkflowRotate++-- ---------------------------------------------------------------------------+-- Running+-- ---------------------------------------------------------------------------++-- | Process-wide count of workflow runs currently in flight, backing the+-- @keiro.workflow.active@ gauge (EP-44). 'runWorkflowWith' brackets each run with+-- @+1@/@-1@ and samples the gauge on both edges, so the exported last-value+-- reflects the true live count whether a run is mid-flight or finished. A+-- process-global 'IORef' is the lightest faithful implementation (the gauge is a+-- last-value-wins level, not a per-run delta), mirroring how the other keiro+-- backlog/level gauges are recorded with a value the runtime already holds.+{-# NOINLINE activeCountRef #-}+activeCountRef :: IORef Int64+activeCountRef = unsafePerformIO (newIORef 0)++-- | Run a workflow computation, journaling each 'step' and replaying any+-- already-journaled steps. Returns 'Completed' when the computation finishes+-- (a 'WorkflowCompleted' marker is journaled) or 'Suspended' when it pauses at+-- an unresolved 'awaitStep'.+--+-- Equivalent to @'runWorkflowWith' 'defaultWorkflowRunOptions'@.+runWorkflow ::+  (IOE :> es, Store :> es, Error StoreError :> es) =>+  WorkflowName ->+  WorkflowId ->+  Eff (Workflow : es) a ->+  Eff es (WorkflowOutcome a)+runWorkflow = runWorkflowWith defaultWorkflowRunOptions++-- | 'runWorkflow' with explicit 'WorkflowRunOptions'. This is the single+-- canonical run entry point; EP-42's resume worker re-invokes through it so+-- resumed runs honor the same options.+--+-- If the workflow's journal already carries a 'WorkflowCancelled' marker (a child+-- cancelled by its parent, EP-43), the run short-circuits immediately and returns+-- 'Cancelled' without executing any step. The handler also re-checks that marker+-- on step/await/patch miss paths and after a fresh step action returns, so a+-- mid-run cancellation stops at the next workflow boundary. A cancellation that+-- lands after the check but before/during the user action may still let that one+-- action run; durable workflow steps remain at-least-once at boundaries. If the+-- journal carries a 'WorkflowFailed' marker, the run likewise short-circuits to+-- 'Failed'. To /propagate/ a finished child's result to its parent, drive the+-- child through 'Keiro.Workflow.Child.runChildWorkflow' rather than this function+-- directly.+runWorkflowWith ::+  forall a es.+  (IOE :> es, Store :> es, Error StoreError :> es) =>+  WorkflowRunOptions ->+  WorkflowName ->+  WorkflowId ->+  Eff (Workflow : es) a ->+  Eff es (WorkflowOutcome a)+runWorkflowWith options name wid action = do+  -- EP-48: resolve the CURRENT (highest) generation once per run and operate+  -- only on it. A never-rotating workflow stays at generation 0, so naming,+  -- load, and append are byte-for-byte as before. A rotated workflow resolves+  -- to its newest generation, so discovery/resume transparently continue there.+  gen <- currentGeneration name wid+  -- Cancellation short-circuit (EP-43): a workflow whose journal carries a+  -- WorkflowCancelled marker makes no further progress. The index row for that+  -- marker is keyed under 'cancelledStepName' on the current generation, so a+  -- single existence check is enough and we never run the user action.+  cancelled <- stepExists name wid gen cancelledStepName+  failed <- stepExists name wid gen failedStepName+  case (cancelled, failed) of+    (True, _) -> pure Cancelled+    (_, True) -> pure Failed+    _ -> runActive gen+  where+    -- EP-44 telemetry handles, pulled from the run options once. Both default+    -- to 'Nothing' (see 'defaultWorkflowRunOptions'), so a default-options run+    -- records nothing and opens no span — the no-op idiom holds end to end.+    mMetrics = options ^. #metrics+    mTracer = options ^. #tracer+    runActive :: Int -> Eff es (WorkflowOutcome a)+    runActive gen =+      -- EP-44: maintain the process-wide live-run count and sample the+      -- @keiro.workflow.active@ gauge on both entry and exit, and open the+      -- whole-run @workflow \<name\>@ span (step 'Nothing'). The body is+      -- unchanged from EP-41 except for the journal-length recording below.+      bracket_+        (liftIO (atomicModifyIORef' activeCountRef (\n -> (n + 1, ()))) >> sampleActive)+        (liftIO (atomicModifyIORef' activeCountRef (\n -> (n - 1, ()))) >> sampleActive)+        (withWorkflowSpan mTracer name wid Nothing (\_sp -> interpreted))+      where+        sampleActive = liftIO (readIORef activeCountRef) >>= recordWorkflowActive mMetrics+        interpreted = do+          initial <- loadJournal options name wid gen+          initial' <- recordPatchSetIfFresh gen initial+          journalRef <- liftIO (newIORef initial')+          ordinalRef <- liftIO (newIORef Map.empty)+          let runHandler = interpret (handler gen journalRef ordinalRef) action+          outcome <-+            (Completed <$> runHandler)+              `catch` (\WorkflowSuspend -> pure Suspended)+              `catch` (\WorkflowCancelPending -> pure Cancelled)+              `catch` ( \(WorkflowRotate seedJson) ->+                          rotateGeneration+                            mMetrics+                            (options ^. #activePatches)+                            name+                            wid+                            gen+                            seedJson+                      )+          case outcome of+            Completed result -> do+              now <- liftIO getCurrentTime+              finalMap <- liftIO (readIORef journalRef)+              -- Idempotent: only appends (and so only snapshots) when the completion+              -- marker is not already journaled. On a replay of an already-completed+              -- workflow this is 'Nothing' and no terminal snapshot is taken (one was+              -- already taken on the original completing run, if the policy fired).+              mAppend <- appendCompletion name wid gen now+              for_ mAppend $ \appendResult ->+                when+                  ( shouldSnapshot+                      (options ^. #snapshotPolicy)+                      Terminal+                      finalMap+                      (appendResult ^. #streamVersion)+                  )+                  (writeWorkflowSnapshotAdvisory mMetrics (appendResult ^. #streamId) (appendResult ^. #streamVersion) finalMap)+              -- EP-44: record one @keiro.workflow.journal.length@ observation per+              -- completing run (the 'Completed' path only, never 'Suspended'),+              -- including a replay that completes again. Length is the recorded+              -- step map plus the WorkflowCompleted marker.+              recordWorkflowJournalLength mMetrics (fromIntegral (Map.size finalMap + 1))+              pure (Completed result)+            Suspended -> markInstanceSuspended name wid >> pure Suspended+            Cancelled -> pure Cancelled+            Failed -> pure Failed+            -- EP-48: the run unwound via 'WorkflowRotate'; 'rotateGeneration'+            -- already journaled the seed step on the next generation and the+            -- rotation marker on this one, so there is nothing more to do here.+            ContinuedAsNew -> pure ContinuedAsNew+        -- Generation 0 has no rotation moment at which to record the patch set,+        -- so it retains the fresh-journal path. Rotated generations receive the+        -- set atomically with their seed in 'rotateGeneration'; this fallback+        -- also keeps generations produced by a pre-change worker compatible.+        recordPatchSetIfFresh runGen initial = do+          let patches = options ^. #activePatches+              freshStart = Map.keysSet initial `Set.isSubsetOf` Set.singleton continueSeedStepName+          if freshStart && not (Set.null patches)+            then do+              let encoded = Aeson.toJSON (map unPatchId (Set.toList patches))+              now <- liftIO getCurrentTime+              appendJournal name wid runGen (StepRecorded patchSetStepName encoded now) >>= \case+                JournalAppended {} -> pure (Map.insert patchSetStepName encoded initial)+                JournalAlreadyPresent stored -> pure (Map.insert patchSetStepName stored initial)+                JournalAppendConflict err -> throwIO (WorkflowJournalAppendError (Text.pack (show err)))+            else pure initial+    handler ::+      Int ->+      IORef (Map Text Aeson.Value) ->+      IORef (Map Text Int) ->+      EffectHandler Workflow es+    handler gen journalRef ordinalRef env operation = case operation of+      Step (StepName key) act -> do+        journal <- liftIO (readIORef journalRef)+        case Map.lookup key journal of+          Just stored -> do+            -- Hit: the step is already journaled, so its recorded result is+            -- returned without re-running @act@ — a replay.+            recordWorkflowStepReplayed mMetrics 1+            decodeStored key stored+          Nothing -> do+            renewLease+            checkCancellationPending name wid gen+            a <- localSeqUnlift env (\unlift -> unlift act)+            checkCancellationPending name wid gen+            let encoded = Aeson.toJSON a+            now <- liftIO getCurrentTime+            appendOutcome <- appendJournal name wid gen (StepRecorded key encoded now)+            case appendOutcome of+              JournalAppended appendResult -> do+                -- Miss: @act@ ran and was journaled — a fresh execution.+                recordWorkflowStepExecuted mMetrics 1+                newMap <-+                  liftIO+                    ( atomicModifyIORef' journalRef $ \m ->+                        let m' = Map.insert key encoded m in (m', m')+                    )+                -- Evaluate the snapshot policy on the post-append map and version;+                -- a step is never the terminal marker, hence @False@.+                when+                  ( shouldSnapshot+                      (options ^. #snapshotPolicy)+                      NotTerminal+                      newMap+                      (appendResult ^. #streamVersion)+                  )+                  (writeWorkflowSnapshotAdvisory mMetrics (appendResult ^. #streamId) (appendResult ^. #streamVersion) newMap)+                decodeStored key encoded+              JournalAlreadyPresent stored -> do+                liftIO+                  ( atomicModifyIORef' journalRef $ \m ->+                      (Map.insert key stored m, ())+                  )+                decodeStored key stored+              JournalAppendConflict err ->+                throwIO (WorkflowJournalAppendError (Text.pack (show err)))+      Await (StepName key) arm -> do+        journal <- liftIO (readIORef journalRef)+        case Map.lookup key journal of+          Just stored -> do+            -- An awaitStep hit means the wake source already resolved this step;+            -- the recorded result is returned without arming — a replay. An+            -- awaitStep miss arms and suspends: no user @action@ ran, so it is+            -- not a step execution and records nothing here.+            recordWorkflowStepReplayed mMetrics 1+            decodeStored key stored+          Nothing ->+            -- The in-memory map can omit a wake completion journaled+            -- while a snapshotting run was mid-flight. The step index+            -- is written transactionally with every append, so consult+            -- it before arming and suspending.+            lookupStepResult name wid gen key >>= \case+              Just stored -> do+                liftIO+                  ( atomicModifyIORef' journalRef $ \m ->+                      (Map.insert key stored m, ())+                  )+                recordWorkflowStepReplayed mMetrics 1+                decodeStored key stored+              Nothing -> do+                renewLease+                checkCancellationPending name wid gen+                localSeqUnlift env (\unlift -> unlift arm)+                throwIO WorkflowSuspend+      CurrentWorkflow -> pure (name, wid)+      CurrentRunGeneration -> pure gen+      FreshOrdinal namespace ->+        liftIO . atomicModifyIORef' ordinalRef $ \counters ->+          let n = Map.findWithDefault 0 namespace counters+           in (Map.insert namespace (n + 1) counters, n)+      -- EP-48: encode the carried seed and throw the rotation sentinel, which+      -- 'runWorkflowWith' catches and turns into 'rotateGeneration'. Never+      -- returns to the caller within this run (result type is polymorphic).+      ContinueAsNew seed -> throwIO (WorkflowRotate (Aeson.toJSON seed))+      -- EP-49: decide and journal a cross-cutting branch. Mirrors the 'Step'+      -- hit/miss shape, but the miss path computes the decision from the+      -- patch set recorded when this workflow generation first started.+      Patch pid -> do+        let key = patchStepName pid+        journal <- liftIO (readIORef journalRef)+        case Map.lookup key journal of+          Just stored ->+            -- Hit: the decision was made on an earlier run; replay it verbatim.+            decodeStored key stored+          Nothing -> do+            checkCancellationPending name wid gen+            recordedSet <- case Map.lookup patchSetStepName journal of+              Nothing -> pure []+              Just stored -> decodeStored patchSetStepName stored+            let decision = unPatchId pid `elem` (recordedSet :: [Text])+                encoded = Aeson.toJSON decision+            now <- liftIO getCurrentTime+            appendOutcome <- appendJournal name wid gen (StepRecorded key encoded now)+            case appendOutcome of+              JournalAppended {} -> do+                liftIO+                  ( atomicModifyIORef' journalRef $ \m ->+                      (Map.insert key encoded m, ())+                  )+                pure decision+              JournalAlreadyPresent stored -> do+                liftIO+                  ( atomicModifyIORef' journalRef $ \m ->+                      (Map.insert key stored m, ())+                  )+                decodeStored key stored+              JournalAppendConflict err ->+                throwIO (WorkflowJournalAppendError (Text.pack (show err)))+      where+        renewLease =+          for_ (options ^. #leaseHeartbeat) $ \heartbeat -> do+            renewed <-+              renewInstanceLease+                (heartbeat ^. #owner)+                (heartbeat ^. #ttl)+                name+                wid+            unless renewed (throwIO WorkflowLeaseLost)++-- | Decode a stored journal result into the type the caller expects.+decodeStored :: (Aeson.FromJSON a) => Text -> Aeson.Value -> Eff es a+decodeStored key stored = case Aeson.fromJSON stored of+  Aeson.Success a -> pure a+  Aeson.Error message -> throwIO (WorkflowStepDecodeError key (Text.pack message))++checkCancellationPending :: (Store :> es) => WorkflowName -> WorkflowId -> Int -> Eff es ()+checkCancellationPending name wid gen = do+  cancelled <- stepExists name wid gen cancelledStepName+  when cancelled (throwIO WorkflowCancelPending)++-- | Pre-load a workflow's journal stream into a @step name -> result@ map.+--+-- If a compatible snapshot exists ('loadWorkflowSnapshot'), seed the map from it+-- and read only the journal events /after/ the snapshot's version ("tail+-- replay"). The reconstructed map is the journal state as the snapshotting run+-- saw it. A wake completion journaled concurrently with that run can fall at or+-- before the snapshot version yet be absent from the seed, so the map may+-- under-approximate the journal. The @Await@ handler compensates by consulting+-- the authoritative @keiro_workflow_steps@ index on a map miss; that index is+-- written transactionally with every journal append.+--+-- A missing, mismatched, or undecodable snapshot is recorded as a miss (and, for+-- undecodable bytes, a decode failure) before the read falls back to a full+-- replay from version 0.+-- 'WorkflowCompleted' contributes nothing to the map.+loadJournal ::+  (IOE :> es, Store :> es) =>+  WorkflowRunOptions ->+  WorkflowName ->+  WorkflowId ->+  Int ->+  Eff es (Map Text Aeson.Value)+loadJournal options name wid gen = do+  let journalName = workflowGenerationStreamName name wid gen+  snapshot <- lookupWorkflowSnapshot journalName+  (seedMap, fromVersion) <- case snapshot of+    Right (m, v) -> do+      recordSnapshotReadHits (options ^. #metrics) 1+      pure (m, v)+    Left reason -> do+      recordSnapshotReadMisses (options ^. #metrics) 1+      case reason of+        SnapshotDecodeFailed _ -> recordSnapshotDecodeFailures (options ^. #metrics) 1+        _ -> pure ()+      pure (Map.empty, StreamVersion 0)+  let events = readStreamForwardStream journalName fromVersion (options ^. #pageSize)+  Streamly.fold (Fold.foldlM' accumulate (pure seedMap)) events+  where+    accumulate journal recorded =+      case decodeRecorded workflowJournalCodec recorded of+        Right (StepRecorded key value _) -> pure (Map.insert key value journal)+        Right (WorkflowCompleted _) -> pure journal+        Right (WorkflowCancelled _) -> pure journal+        Right (WorkflowFailed _ _) -> pure journal+        Right (WorkflowContinuedAsNew _ _) -> pure journal -- a rotation marker carries no step result+        Left err -> throwIO (WorkflowJournalDecodeError (Text.pack (show err)))++-- ---------------------------------------------------------------------------+-- Journal append helpers+-- ---------------------------------------------------------------------------++data JournalAppendOutcome+  = JournalAppended !AppendResult+  | JournalAlreadyPresent !Aeson.Value+  | JournalAppendConflict !AppendConflict+  deriving stock (Eq, Show)++prepareJournalAppend ::+  (IOE :> es) =>+  WorkflowName ->+  WorkflowId ->+  Int ->+  WorkflowJournalEvent ->+  Eff es (Tx.Transaction JournalAppendOutcome)+prepareJournalAppend name wid gen event = do+  let key = journalKey event+      entryId = deterministicJournalId name wid gen key+      requestedEntryId = case event of+        -- Resurrection removes the derived failure-marker index row while+        -- retaining append-only journal history. A later failure on the+        -- same generation therefore needs a fresh UUIDv7; step locking and+        -- the in-transaction index check still deduplicate concurrent+        -- failure writers.+        WorkflowFailed {} -> Nothing+        _ -> Just entryId+      row = journalRow name wid gen event+      (status, mLastError) = instanceStatusForEvent event+      journalName = workflowGenerationStreamName name wid gen+      lockKey =+        Text.intercalate+          "/"+          [unWorkflowId wid, unWorkflowName name, Text.pack (show gen), key]+  base <- case encodeForAppendWithMetadata workflowJournalCodec Nothing event of+    Right encoded -> pure encoded+    Left err -> throwIO (WorkflowJournalEncodeError (Text.pack (show err)))+  let entry = base & #eventId .~ requestedEntryId :: EventData+  prepared <- prepareEventsIO [entry]+  now <- liftIO getCurrentTime+  pure $ do+    lockWorkflowStepTx lockKey+    lookupStepResultTx (unWorkflowId wid) (unWorkflowName name) gen key >>= \case+      Just stored -> pure (JournalAlreadyPresent stored)+      Nothing ->+        appendToStreamTx journalName AnyVersion prepared now >>= \case+          Left err -> pure (JournalAppendConflict err)+          Right appendResult ->+            JournalAppended appendResult+              <$ recordStepTx row+              <* upsertInstanceTx+                (unWorkflowId wid)+                (unWorkflowName name)+                (fromIntegral gen)+                status+                mLastError++appendJournal :: (IOE :> es, Store :> es) => WorkflowName -> WorkflowId -> Int -> WorkflowJournalEvent -> Eff es JournalAppendOutcome+appendJournal name wid gen event =+  prepareJournalAppend name wid gen event >>= runTransaction++-- | Append a journal event to a workflow's journal stream (and keep its+-- index row consistent), idempotently. If the entry already exists this is a+-- no-op returning the would-be event id.+--+-- This is the integration helper a wake source's external-completion path uses+-- to record an awaited step's resolution. The append uses a deterministic event+-- id derived from @("keiro" : "workflow" : name : id : stepName)@ so concurrent+-- or retried writes collapse to one row.+appendJournalEntry :: (IOE :> es, Store :> es) => WorkflowName -> WorkflowId -> WorkflowJournalEvent -> Eff es ()+appendJournalEntry name wid event = void (appendJournalEntryReturningId name wid event)++-- | Like 'appendJournalEntry' but returns the (deterministic) 'EventId' of+-- the entry. EP-39's fired timer needs this for @markTimerFired@.+appendJournalEntryReturningId :: (IOE :> es, Store :> es) => WorkflowName -> WorkflowId -> WorkflowJournalEvent -> Eff es EventId+appendJournalEntryReturningId name wid event = do+  -- EP-48: a wake source (timer fired, signalAwakeable, child completion)+  -- resolves the awaited step on whichever generation the suspended run is+  -- parked on — always the current (highest) one, since runs only ever operate+  -- on the current generation. Resolve it here so the append and its+  -- deterministic id are namespaced by that generation.+  gen <- currentGeneration name wid+  let key = journalKey event+      entryId = deterministicJournalId name wid gen key+  appendJournal name wid gen event >>= \case+    JournalAppended {} -> pure entryId+    JournalAlreadyPresent {} -> pure entryId+    JournalAppendConflict err -> throwIO (WorkflowJournalAppendError (Text.pack (show err)))++-- | Append a journal entry only if it is not already journaled, returning the+-- 'AppendResult' of the fresh append (or 'Nothing' if it already existed). Used+-- on the completion path so a terminal ('OnTerminal') snapshot can be taken from+-- the completing run's 'AppendResult', while a replay of an already-completed+-- workflow is a no-op.+appendCompletion :: (IOE :> es, Store :> es) => WorkflowName -> WorkflowId -> Int -> UTCTime -> Eff es (Maybe AppendResult)+appendCompletion name wid gen now = do+  appendJournal name wid gen (WorkflowCompleted now) >>= \case+    JournalAppended appendResult -> pure (Just appendResult)+    JournalAlreadyPresent {} -> pure Nothing+    JournalAppendConflict err -> throwIO (WorkflowJournalAppendError (Text.pack (show err)))++-- | Perform a continue-as-new rotation (EP-48): close generation @gen@ and open+-- generation @gen + 1@, seeded with @seedJson@ and the deployed patch set. Returns+-- 'ContinuedAsNew'.+--+-- The next generation's seed and non-empty patch set are appended in one+-- transaction before the old generation's rotation marker. The seed advances+-- @MAX(generation)@ — and therefore 'currentGeneration' — to @gen + 1@, while the+-- same commit makes patch decisions available before any asynchronous wake writer+-- can append to the new generation. After that commit, any re-run resolves the+-- current generation to @gen + 1@, hydrates from the seed and patch set, and never+-- re-enters generation @gen@. We then append the terminal+-- 'WorkflowContinuedAsNew' marker on generation @gen@. Every append is guarded by+-- an existence check and uses a deterministic, generation-namespaced id, so the+-- whole rotation is idempotent.+--+-- The seed carries state forward and the patch-set entry freezes code-evolution+-- decisions. We snapshot their map at the newest fresh append's version so the+-- next generation hydrates in O(1). The snapshot is advisory, so it is written+-- unconditionally on rotation regardless of the run's 'snapshotPolicy' — rotation+-- is exactly when a fresh snapshot earns its keep.+rotateGeneration ::+  forall a es.+  (IOE :> es, Store :> es, Error StoreError :> es) =>+  Maybe KeiroMetrics ->+  Set PatchId ->+  WorkflowName ->+  WorkflowId ->+  Int ->+  Aeson.Value ->+  Eff es (WorkflowOutcome a)+rotateGeneration mMetrics patches name wid gen seedJson = do+  let nextGen = gen + 1+      encodedPatches = Aeson.toJSON (map unPatchId (Set.toList patches))+      patchEvent =+        StepRecorded patchSetStepName encodedPatches+  now <- liftIO getCurrentTime+  seedTx <-+    prepareJournalAppend+      name+      wid+      nextGen+      (StepRecorded continueSeedStepName seedJson now)+  patchTx <-+    if Set.null patches+      then pure Nothing+      else+        Just+          <$> prepareJournalAppend+            name+            wid+            nextGen+            (patchEvent now)+  -- 1. Seed and patch set on the NEXT generation in one transaction. A+  -- conflict condemns the whole transaction before it returns its diagnostic+  -- outcome, so no seed-without-patch intermediate state can commit.+  (seedOutcome, patchOutcome) <-+    runTransaction $ do+      seedResult <- seedTx+      condemnOnConflict seedResult+      patchResult <- traverse id patchTx+      traverse_ condemnOnConflict patchResult+      pure (seedResult, patchResult)+  throwOnConflict seedOutcome+  traverse_ throwOnConflict patchOutcome+  let seedValue = recordedValue seedJson seedOutcome+      snapshotState =+        maybe+          (Map.singleton continueSeedStepName seedValue)+          ( \outcome ->+              Map.fromList+                [ (continueSeedStepName, seedValue),+                  (patchSetStepName, recordedValue encodedPatches outcome)+                ]+          )+          patchOutcome+      snapshotAppend =+        case patchOutcome of+          Just (JournalAppended appendResult) -> Just appendResult+          _ -> case seedOutcome of+            JournalAppended appendResult -> Just appendResult+            _ -> Nothing+  for_ snapshotAppend $ \appendResult ->+    writeWorkflowSnapshotAdvisory+      mMetrics+      (appendResult ^. #streamId)+      (appendResult ^. #streamVersion)+      snapshotState+  -- 2. Terminal rotation marker on the CURRENT generation (audit + closes it).+  appendJournal name wid gen (WorkflowContinuedAsNew nextGen now) >>= \case+    JournalAppended {} -> pure ()+    JournalAlreadyPresent {} -> pure ()+    JournalAppendConflict err -> throwIO (WorkflowJournalAppendError (Text.pack (show err)))+  pure ContinuedAsNew+  where+    condemnOnConflict = \case+      JournalAppendConflict {} -> Tx.condemn+      _ -> pure ()+    throwOnConflict = \case+      JournalAppendConflict err ->+        throwIO (WorkflowJournalAppendError (Text.pack (show err)))+      _ -> pure ()+    recordedValue fallback = \case+      JournalAlreadyPresent stored -> stored+      _ -> fallback++-- | Snapshot a workflow state after its journal append has committed. The+-- snapshot is advisory: a store failure is counted and cannot turn the+-- already-durable workflow transition into a failed run.+writeWorkflowSnapshotAdvisory ::+  (IOE :> es, Store :> es, Error StoreError :> es) =>+  Maybe KeiroMetrics ->+  StreamId ->+  StreamVersion ->+  WorkflowState ->+  Eff es ()+writeWorkflowSnapshotAdvisory mMetrics streamId version state = do+  -- WorkflowState is already a Map Text Value assembled from journaled step+  -- results, so this path has no aggregate RegFile/uninit encode to guard.+  outcome <- tryError @StoreError (writeWorkflowSnapshot streamId version state)+  case outcome of+    Right () -> pure ()+    Left _ -> recordSnapshotWriteFailures mMetrics 1++instanceStatusForEvent :: WorkflowJournalEvent -> (WorkflowStatus, Maybe Text)+instanceStatusForEvent = \case+  StepRecorded {} -> (WfRunning, Nothing)+  WorkflowCompleted {} -> (WfCompleted, Nothing)+  WorkflowCancelled {} -> (WfCancelled, Nothing)+  WorkflowFailed reason _ -> (WfFailed, Just reason)+  WorkflowContinuedAsNew {} -> (WfRunning, Nothing)++-- | The reserved step-name key a journal event indexes under.+journalKey :: WorkflowJournalEvent -> Text+journalKey = \case+  StepRecorded {stepName = key} -> key+  WorkflowCompleted {} -> completedStepName+  WorkflowCancelled {} -> cancelledStepName+  WorkflowFailed {} -> failedStepName+  WorkflowContinuedAsNew {} -> continuedAsNewStepName++-- | The index row corresponding to a journal event, on the given generation.+journalRow :: WorkflowName -> WorkflowId -> Int -> WorkflowJournalEvent -> WorkflowStepRow+journalRow name wid gen = \case+  StepRecorded key value t ->+    WorkflowStepRow+      { workflowId = unWorkflowId wid,+        workflowName = unWorkflowName name,+        generation = gen,+        stepName = key,+        result = value,+        recordedAt = t+      }+  WorkflowCompleted t ->+    WorkflowStepRow+      { workflowId = unWorkflowId wid,+        workflowName = unWorkflowName name,+        generation = gen,+        stepName = completedStepName,+        result = Aeson.Null,+        recordedAt = t+      }+  WorkflowCancelled t ->+    WorkflowStepRow+      { workflowId = unWorkflowId wid,+        workflowName = unWorkflowName name,+        generation = gen,+        stepName = cancelledStepName,+        result = Aeson.Null,+        recordedAt = t+      }+  WorkflowFailed r t ->+    WorkflowStepRow+      { workflowId = unWorkflowId wid,+        workflowName = unWorkflowName name,+        generation = gen,+        stepName = failedStepName,+        result = Aeson.toJSON r,+        recordedAt = t+      }+  WorkflowContinuedAsNew g t ->+    WorkflowStepRow+      { workflowId = unWorkflowId wid,+        workflowName = unWorkflowName name,+        generation = gen,+        stepName = continuedAsNewStepName,+        result = Aeson.toJSON g, -- the NEXT generation this rotation opens+        recordedAt = t+      }++-- | A stable, collision-resistant journal-event id from+-- @("keiro" : "workflow" : name : id : generation : stepName)@ via a v5 UUID.+-- Mirrors 'Keiro.ProcessManager.deterministicCommandId': the same inputs always+-- yield the same id, so a re-append of the same step collapses to the same row.+--+-- The /generation/ (EP-48) is part of the id so a step named @"s1"@ in+-- generation 0 and the same name in generation 1 produce __different__ kiroku+-- event ids — they live on different physical streams, but the event id is+-- global, so namespacing it by generation keeps rotated generations from+-- colliding on the deterministic id.+deterministicJournalId :: WorkflowName -> WorkflowId -> Int -> Text -> EventId+deterministicJournalId (WorkflowName name) (WorkflowId wid) gen key =+  EventId $+    UUID.V5.generateNamed UUID.V5.namespaceURL $+      fmap (fromIntegral . fromEnum) $+        Text.unpack $+          Text.intercalate ":" ["keiro", "workflow", name, wid, Text.pack (show gen), key]
src/Keiro/Workflow/Awakeable.hs view
@@ -1,57 +1,56 @@-{- | Awakeables: durable promises an external system resolves.--== What this gives you--A workflow allocates an opaque 'AwakeableId', hands it to some external system-(a webhook handler, a human approver, an LLM tool call), and suspends until-that system /signals/ the id with a result — no polling, no bespoke-"wait for event X then react in a process manager" wiring.--@-approvalFlow :: ('Workflow' ':>' es, 'Store' ':>' es, 'IOE' ':>' es) => Eff es Text-approvalFlow = do-  (aid, await) <- 'awakeableNamed' (StepName \"approval\")  -- allocate the promise-  -- (hand @aid@ to a webhook handler / human / LLM tool here)-  decision <- await                                       -- SUSPEND until signalled-  'Keiro.Workflow.step' (StepName \"use\") (pure (decision <> \"!\"))-@--The @pending@ row is committed as part of the journaled allocation step,-before the id can be returned or handed to an external system. On the __first__-'Keiro.Workflow.runWorkflow' this returns 'Suspended' (the run parked on-@await@). An external caller later runs-@'signalAwakeable' aid \"ok\"@, which flips the row to @completed@ /and/-appends a @StepRecorded \"awk:\<uuid\>\"@ to the workflow's journal. The-__next__ run replays past the now-resolved @await@ and 'Completed's.--== Contract recap for downstream plans (the v2 MasterPlan)--* 'AwakeableId' is journaled randomness: new allocations generate an opaque v4-  UUID and record it under @awkid:\<label\>@ before awaiting @awk:\<uuid\>@.-  Replay reads the journaled id, so a resumed workflow allocates the same id it-  already handed out without making that id guessable from public coordinates.-* 'awakeableNamed' (caller-supplied label) is the __stable primitive__;-  'awakeable' is an ordinal convenience whose label is positional (a fragile-  derivation across code edits — see its Haddock).-* Awakeables journal their completion as ordinary 'StepRecorded' events under-  the reserved @awk:@ prefix ('Keiro.Workflow.awakeableStepPrefix'), never a-  new event type, so EP-38's replay loop stays uniform.-* 'signalAwakeable' is idempotent /and/ crash-safe: it commits the row update-  and journal append in one transaction for new signals, a double signal-  returns 'False' and does not change the recorded value, and a signal of an-  already-@completed@ awakeable re-appends the journal entry from the stored-  payload to repair historical wedges. A signal that loses a row race to-  cancellation returns 'False' without appending.-* 'cancelAwakeable' abandons a still-@pending@ promise; a workflow that-  re-enters its @await@ then throws 'WorkflowAwakeableCancelled', which the-  author can @catch@ for compensation. If uncaught, EP-42's resume worker-  records an attempt, backs off, and eventually appends 'WorkflowFailed' at the-  configured failure ceiling.-* @countPendingAwakeables@ (in "Keiro.Workflow.Awakeable.Schema") backs EP-44's-  @keiro.workflow.awakeables.pending@ gauge.--}-module Keiro.Workflow.Awakeable (-    -- * Awakeable ids+-- | Awakeables: durable promises an external system resolves.+--+-- == What this gives you+--+-- A workflow allocates an opaque 'AwakeableId', hands it to some external system+-- (a webhook handler, a human approver, an LLM tool call), and suspends until+-- that system /signals/ the id with a result — no polling, no bespoke+-- "wait for event X then react in a process manager" wiring.+--+-- @+-- approvalFlow :: ('Workflow' ':>' es, 'Store' ':>' es, 'IOE' ':>' es) => Eff es Text+-- approvalFlow = do+--   (aid, await) <- 'awakeableNamed' (StepName \"approval\")  -- allocate the promise+--   -- (hand @aid@ to a webhook handler / human / LLM tool here)+--   decision <- await                                       -- SUSPEND until signalled+--   'Keiro.Workflow.step' (StepName \"use\") (pure (decision <> \"!\"))+-- @+--+-- The @pending@ row is committed as part of the journaled allocation step,+-- before the id can be returned or handed to an external system. On the __first__+-- 'Keiro.Workflow.runWorkflow' this returns 'Suspended' (the run parked on+-- @await@). An external caller later runs+-- @'signalAwakeable' aid \"ok\"@, which flips the row to @completed@ /and/+-- appends a @StepRecorded \"awk:\<uuid\>\"@ to the workflow's journal. The+-- __next__ run replays past the now-resolved @await@ and 'Completed's.+--+-- == Contract recap for downstream plans (the v2 MasterPlan)+--+-- * 'AwakeableId' is journaled randomness: new allocations generate an opaque v4+--   UUID and record it under @awkid:\<label\>@ before awaiting @awk:\<uuid\>@.+--   Replay reads the journaled id, so a resumed workflow allocates the same id it+--   already handed out without making that id guessable from public coordinates.+-- * 'awakeableNamed' (caller-supplied label) is the __stable primitive__;+--   'awakeable' is an ordinal convenience whose label is positional (a fragile+--   derivation across code edits — see its Haddock).+-- * Awakeables journal their completion as ordinary 'StepRecorded' events under+--   the reserved @awk:@ prefix ('Keiro.Workflow.awakeableStepPrefix'), never a+--   new event type, so EP-38's replay loop stays uniform.+-- * 'signalAwakeable' is idempotent /and/ crash-safe: it commits the row update+--   and journal append in one transaction for new signals, a double signal+--   returns 'False' and does not change the recorded value, and a signal of an+--   already-@completed@ awakeable re-appends the journal entry from the stored+--   payload to repair historical wedges. A signal that loses a row race to+--   cancellation returns 'False' without appending.+-- * 'cancelAwakeable' abandons a still-@pending@ promise; a workflow that+--   re-enters its @await@ then throws 'WorkflowAwakeableCancelled', which the+--   author can @catch@ for compensation. If uncaught, EP-42's resume worker+--   records an attempt, backs off, and eventually appends 'WorkflowFailed' at the+--   configured failure ceiling.+-- * @countPendingAwakeables@ (in "Keiro.Workflow.Awakeable.Schema") backs EP-44's+--   @keiro.workflow.awakeables.pending@ gauge.+module Keiro.Workflow.Awakeable+  ( -- * Awakeable ids     AwakeableId (..),     awakeableIdToUuid,     awakeableIdText,@@ -68,7 +67,7 @@      -- * Errors     WorkflowAwakeableCancelled (..),-)+  ) where  import Control.Exception (Exception)@@ -80,8 +79,8 @@ import Effectful (Eff, IOE, (:>)) import Effectful.Exception (throwIO) import Keiro.Prelude-import Keiro.Workflow (-    JournalAppendOutcome (..),+import Keiro.Workflow+  ( JournalAppendOutcome (..),     StepName (..),     Workflow,     WorkflowError (..),@@ -98,16 +97,16 @@     freshOrdinal,     prepareJournalAppend,     step,- )-import Keiro.Workflow.Awakeable.Schema (-    AwakeableRow,+  )+import Keiro.Workflow.Awakeable.Schema+  ( AwakeableRow,     AwakeableStatus (..),     cancelAwakeableTx,     completeAwakeableTx,     lookupAwakeable,     lookupAwakeableStatusTx,     registerAwakeableTx,- )+  ) import Kiroku.Store.Effect (Store) import Kiroku.Store.Transaction (runTransaction) import "hasql-transaction" Hasql.Transaction qualified as Tx@@ -116,55 +115,51 @@ -- Awakeable ids -- --------------------------------------------------------------------------- -{- | The opaque id of an awakeable. New allocations are random and journaled by-'awakeableNamed'; 'deterministicAwakeableId' is retained only as a legacy-generation-0 adoption helper. The @ToJSON@\/@FromJSON@ instances are over the-inner UUID, so the workflow journal can replay the id and webhook payloads may-carry it.--}+-- | The opaque id of an awakeable. New allocations are random and journaled by+-- 'awakeableNamed'; 'deterministicAwakeableId' is retained only as a legacy+-- generation-0 adoption helper. The @ToJSON@\/@FromJSON@ instances are over the+-- inner UUID, so the workflow journal can replay the id and webhook payloads may+-- carry it. newtype AwakeableId = AwakeableId UUID-    deriving stock (Eq, Show, Generic)-    deriving newtype (ToJSON, FromJSON)+  deriving stock (Eq, Show, Generic)+  deriving newtype (ToJSON, FromJSON)  -- | The raw UUID inside an 'AwakeableId'. awakeableIdToUuid :: AwakeableId -> UUID awakeableIdToUuid (AwakeableId u) = u -{- | The 'AwakeableId' rendered as text — the suffix of the @awk:\<uuid\>@-journal step name an awakeable's completion is recorded under.--}+-- | The 'AwakeableId' rendered as text — the suffix of the @awk:\<uuid\>@+-- journal step name an awakeable's completion is recorded under. awakeableIdText :: AwakeableId -> Text awakeableIdText = UUID.toText . awakeableIdToUuid -{- | The legacy deterministic 'AwakeableId' for a @(workflow name, workflow id,-label)@: a v5 UUID over @(\"keiro\":\"awakeable\":name:id:label)@.--This is predictable from public coordinates, so new code must not hand-derive-ids with it. It remains exported for operators and for generation-0 adoption:-if a pre-change workflow already registered a row under this id, the first-post-change allocation adopts that row so the in-flight promise keeps working.--}+-- | The legacy deterministic 'AwakeableId' for a @(workflow name, workflow id,+-- label)@: a v5 UUID over @(\"keiro\":\"awakeable\":name:id:label)@.+--+-- This is predictable from public coordinates, so new code must not hand-derive+-- ids with it. It remains exported for operators and for generation-0 adoption:+-- if a pre-change workflow already registered a row under this id, the first+-- post-change allocation adopts that row so the in-flight promise keeps working. deterministicAwakeableId :: WorkflowName -> WorkflowId -> Text -> AwakeableId deterministicAwakeableId (WorkflowName name) (WorkflowId wid) label =-    AwakeableId $-        UUID.V5.generateNamed UUID.V5.namespaceURL $-            fmap (fromIntegral . fromEnum) $-                Text.unpack $-                    Text.intercalate ":" ["keiro", "awakeable", name, wid, label]+  AwakeableId $+    UUID.V5.generateNamed UUID.V5.namespaceURL $+      fmap (fromIntegral . fromEnum) $+        Text.unpack $+          Text.intercalate ":" ["keiro", "awakeable", name, wid, label]  -- --------------------------------------------------------------------------- -- Errors -- --------------------------------------------------------------------------- -{- | Thrown out of 'Keiro.Workflow.runWorkflow' when a workflow re-enters the-@await@ of an awakeable that was 'cancelAwakeable'd. A cancelled awakeable will-never be signalled, so suspending forever would be wrong and silently-completing would fabricate a result; the workflow author can @catch@ this to-run compensation. If uncaught, the resume worker records the attempt and-eventually marks the workflow failed at its configured ceiling.--}+-- | Thrown out of 'Keiro.Workflow.runWorkflow' when a workflow re-enters the+-- @await@ of an awakeable that was 'cancelAwakeable'd. A cancelled awakeable will+-- never be signalled, so suspending forever would be wrong and silently+-- completing would fabricate a result; the workflow author can @catch@ this to+-- run compensation. If uncaught, the resume worker records the attempt and+-- eventually marks the workflow failed at its configured ceiling. newtype WorkflowAwakeableCancelled = WorkflowAwakeableCancelled AwakeableId-    deriving stock (Eq, Show)+  deriving stock (Eq, Show)  instance Exception WorkflowAwakeableCancelled @@ -172,210 +167,203 @@ -- Authoring surface -- --------------------------------------------------------------------------- -{- | Allocate an awakeable under the stable, caller-supplied @label@. Returns-the 'AwakeableId' (hand it to the external system) and an @await@ action that-'Suspended's the workflow until the awakeable is signalled, then yields the-decoded payload on a later run.--The @label@ is the only fully-deterministic option: it survives code edits that-insert or remove awakeables elsewhere in the workflow (the same robustness-argument EP-38 makes for named steps over positional history). Prefer this over-'awakeable' for anything that may outlive a code change mid-flight.--}+-- | Allocate an awakeable under the stable, caller-supplied @label@. Returns+-- the 'AwakeableId' (hand it to the external system) and an @await@ action that+-- 'Suspended's the workflow until the awakeable is signalled, then yields the+-- decoded payload on a later run.+--+-- The @label@ is the only fully-deterministic option: it survives code edits that+-- insert or remove awakeables elsewhere in the workflow (the same robustness+-- argument EP-38 makes for named steps over positional history). Prefer this over+-- 'awakeable' for anything that may outlive a code change mid-flight. awakeableNamed ::-    (Workflow :> es, Store :> es, IOE :> es, FromJSON a) =>-    StepName ->-    Eff es (AwakeableId, Eff es a)+  (Workflow :> es, Store :> es, IOE :> es, FromJSON a) =>+  StepName ->+  Eff es (AwakeableId, Eff es a) awakeableNamed (StepName label) = do-    (name, wid) <- currentWorkflow-    gen <- currentRunGeneration-    aid <--        step (StepName (awakeableAllocStepPrefix <> label)) $ do-            allocated <- allocateAwakeableId name wid gen label-            runTransaction $-                registerAwakeableTx-                    (awakeableIdToUuid allocated)-                    (unWorkflowName name)-                    (unWorkflowId wid)-            pure allocated-    let-        stepNm = StepName (awakeableStepPrefix <> awakeableIdText aid)-        await = awaitCancellable name wid aid stepNm-    pure (aid, await)+  (name, wid) <- currentWorkflow+  gen <- currentRunGeneration+  aid <-+    step (StepName (awakeableAllocStepPrefix <> label)) $ do+      allocated <- allocateAwakeableId name wid gen label+      runTransaction $+        registerAwakeableTx+          (awakeableIdToUuid allocated)+          (unWorkflowName name)+          (unWorkflowId wid)+      pure allocated+  let stepNm = StepName (awakeableStepPrefix <> awakeableIdText aid)+      await = awaitCancellable name wid aid stepNm+  pure (aid, await)  allocateAwakeableId ::-    (Store :> es, IOE :> es) =>-    WorkflowName ->-    WorkflowId ->-    Int ->-    Text ->-    Eff es AwakeableId+  (Store :> es, IOE :> es) =>+  WorkflowName ->+  WorkflowId ->+  Int ->+  Text ->+  Eff es AwakeableId allocateAwakeableId name wid gen label-    | gen <= 0 = do-        let legacy = deterministicAwakeableId name wid label-        existing <- lookupAwakeable (awakeableIdToUuid legacy)-        case existing of-            Just _ -> pure legacy-            Nothing -> AwakeableId <$> liftIO UUID.V4.nextRandom-    | otherwise = AwakeableId <$> liftIO UUID.V4.nextRandom+  | gen <= 0 = do+      let legacy = deterministicAwakeableId name wid label+      existing <- lookupAwakeable (awakeableIdToUuid legacy)+      case existing of+        Just _ -> pure legacy+        Nothing -> AwakeableId <$> liftIO UUID.V4.nextRandom+  | otherwise = AwakeableId <$> liftIO UUID.V4.nextRandom -{- | Allocate an awakeable under an ordinal label (the @N@th awakeable in a run-becomes @ord:N@). Convenient, but its determinism is __conditional__: adding or-removing an 'awakeable' call earlier in the workflow shifts every later ordinal-and so changes their derived ids, which corrupts an in-flight workflow exactly-the way EP-38 warns positional history does. Prefer 'awakeableNamed' for-anything that may outlive a code edit.--}+-- | Allocate an awakeable under an ordinal label (the @N@th awakeable in a run+-- becomes @ord:N@). Convenient, but its determinism is __conditional__: adding or+-- removing an 'awakeable' call earlier in the workflow shifts every later ordinal+-- and so changes their derived ids, which corrupts an in-flight workflow exactly+-- the way EP-38 warns positional history does. Prefer 'awakeableNamed' for+-- anything that may outlive a code edit. awakeable ::-    (Workflow :> es, Store :> es, IOE :> es, FromJSON a) =>-    Eff es (AwakeableId, Eff es a)+  (Workflow :> es, Store :> es, IOE :> es, FromJSON a) =>+  Eff es (AwakeableId, Eff es a) awakeable = do-    n <- freshOrdinal awakeableStepPrefix-    awakeableNamed (StepName ("ord:" <> Text.pack (show n)))+  n <- freshOrdinal awakeableStepPrefix+  awakeableNamed (StepName ("ord:" <> Text.pack (show n))) -{- | EP-38's 'awaitStep', wrapped so that a re-entered @await@ on a-'Cancelled' awakeable throws 'WorkflowAwakeableCancelled' instead of suspending-forever. The check lives /inside/ the arming action because 'awaitStep' runs-@arm@ only on the miss path (the awakeable not yet journaled) and re-runs it on-every resume until it resolves: on a miss we either notice the cancel and throw,-or (re-)register the idempotent @pending@ row and suspend. On the hit path-('signalAwakeable' already journaled the result) @arm@ is never run, so a-signalled-then-cancelled race still returns the signalled value (signal wins — a-resolved promise cannot be un-resolved).--}+-- | EP-38's 'awaitStep', wrapped so that a re-entered @await@ on a+-- 'Cancelled' awakeable throws 'WorkflowAwakeableCancelled' instead of suspending+-- forever. The check lives /inside/ the arming action because 'awaitStep' runs+-- @arm@ only on the miss path (the awakeable not yet journaled) and re-runs it on+-- every resume until it resolves: on a miss we either notice the cancel and throw,+-- or (re-)register the idempotent @pending@ row and suspend. On the hit path+-- ('signalAwakeable' already journaled the result) @arm@ is never run, so a+-- signalled-then-cancelled race still returns the signalled value (signal wins — a+-- resolved promise cannot be un-resolved). awaitCancellable ::-    (Workflow :> es, Store :> es, IOE :> es, FromJSON a) =>-    WorkflowName -> WorkflowId -> AwakeableId -> StepName -> Eff es a+  (Workflow :> es, Store :> es, IOE :> es, FromJSON a) =>+  WorkflowName -> WorkflowId -> AwakeableId -> StepName -> Eff es a awaitCancellable name wid aid stepNm =-    awaitStep stepNm $ do-        existing <- lookupAwakeable (awakeableIdToUuid aid)-        case existing of-            Just row-                | row ^. #status == Cancelled ->-                    throwIO (WorkflowAwakeableCancelled aid)-                | row ^. #status == Completed-                , Just payload <- row ^. #payload -> do-                    now <- liftIO getCurrentTime-                    appendJournalEntry-                        name-                        wid-                        StepRecorded-                            { stepName = unStepName stepNm-                            , result = payload-                            , recordedAt = now-                            }-            _ ->-                runTransaction $-                    registerAwakeableTx (awakeableIdToUuid aid) (unWorkflowName name) (unWorkflowId wid)+  awaitStep stepNm $ do+    existing <- lookupAwakeable (awakeableIdToUuid aid)+    case existing of+      Just row+        | row ^. #status == Cancelled ->+            throwIO (WorkflowAwakeableCancelled aid)+        | row ^. #status == Completed,+          Just payload <- row ^. #payload -> do+            now <- liftIO getCurrentTime+            appendJournalEntry+              name+              wid+              StepRecorded+                { stepName = unStepName stepNm,+                  result = payload,+                  recordedAt = now+                }+      _ ->+        runTransaction $+          registerAwakeableTx (awakeableIdToUuid aid) (unWorkflowName name) (unWorkflowId wid)  -- --------------------------------------------------------------------------- -- External completion -- --------------------------------------------------------------------------- -{- | Resolve an awakeable from outside the workflow: store @result@ in the-@keiro_awakeables@ row /and/ append a @StepRecorded@ to the owning workflow's-journal so the next run replays past the @await@.--Idempotent and crash-safe:--* Returns 'True' only when /this/ call transitioned the row @pending@ ->-  @completed@; a second signal (or a signal of a @cancelled@ row) returns-  'False' and leaves the stored payload unchanged.-* For a @pending@ row, the row transition and journal append happen in one-  transaction. For an already-@completed@ row, the journal entry is re-appended-  from the stored payload to repair rows wedged before that atomic path existed.-  The append path is idempotent (deterministic event id plus step-index check),-  so a re-append collapses to a no-op once the entry is present.-* If a cancellation wins after this function's initial row read but before its-  guarded completion, the transaction re-reads the status and appends nothing.-  The signal returns 'False', so cancellation cannot both trigger compensation-  and leak a completion value into the workflow journal.--A 'False' return therefore does not mean "nothing happened": the journal may-still have been repaired. Returns 'False' for an unknown id.--}+-- | Resolve an awakeable from outside the workflow: store @result@ in the+-- @keiro_awakeables@ row /and/ append a @StepRecorded@ to the owning workflow's+-- journal so the next run replays past the @await@.+--+-- Idempotent and crash-safe:+--+-- * Returns 'True' only when /this/ call transitioned the row @pending@ ->+--   @completed@; a second signal (or a signal of a @cancelled@ row) returns+--   'False' and leaves the stored payload unchanged.+-- * For a @pending@ row, the row transition and journal append happen in one+--   transaction. For an already-@completed@ row, the journal entry is re-appended+--   from the stored payload to repair rows wedged before that atomic path existed.+--   The append path is idempotent (deterministic event id plus step-index check),+--   so a re-append collapses to a no-op once the entry is present.+-- * If a cancellation wins after this function's initial row read but before its+--   guarded completion, the transaction re-reads the status and appends nothing.+--   The signal returns 'False', so cancellation cannot both trigger compensation+--   and leak a completion value into the workflow journal.+--+-- A 'False' return therefore does not mean "nothing happened": the journal may+-- still have been repaired. Returns 'False' for an unknown id. signalAwakeable :: (IOE :> es, Store :> es, ToJSON r) => AwakeableId -> r -> Eff es Bool signalAwakeable aid result =-    lookupAwakeable (awakeableIdToUuid aid) >>= \case-        Nothing -> pure False-        Just row -> signalAwakeableFrom row result--{- | The transaction-decision core of 'signalAwakeable', exposed so race-contracts can deterministically interpose between the initial row read and the-guarded completion. Normal callers should use 'signalAwakeable'.+  lookupAwakeable (awakeableIdToUuid aid) >>= \case+    Nothing -> pure False+    Just row -> signalAwakeableFrom row result -The supplied row may be stale. This function therefore trusts it only for the-owner coordinates and candidate payload; when a pending-to-completed UPDATE-loses, it re-reads status inside the same transaction and appends only if-another signal completed the row. A winning cancellation gets no append.--}+-- | The transaction-decision core of 'signalAwakeable', exposed so race+-- contracts can deterministically interpose between the initial row read and the+-- guarded completion. Normal callers should use 'signalAwakeable'.+--+-- The supplied row may be stale. This function therefore trusts it only for the+-- owner coordinates and candidate payload; when a pending-to-completed UPDATE+-- loses, it re-reads status inside the same transaction and appends only if+-- another signal completed the row. A winning cancellation gets no append. signalAwakeableFrom ::-    (IOE :> es, Store :> es, ToJSON r) =>-    AwakeableRow ->-    r ->-    Eff es Bool+  (IOE :> es, Store :> es, ToJSON r) =>+  AwakeableRow ->+  r ->+  Eff es Bool signalAwakeableFrom row result-    | row ^. #status == Cancelled = pure False-    | otherwise = do-        now <- liftIO getCurrentTime-        let aid = AwakeableId (row ^. #awakeableId)-            payload =-                if row ^. #status == Completed-                    then row ^. #payload-                    else Just (toJSON result)-        case payload of-            Nothing -> pure False-            Just payloadValue -> do-                let ownerName = WorkflowName (row ^. #ownerWorkflowName)-                    ownerId = WorkflowId (row ^. #ownerWorkflowId)-                gen <- currentGeneration ownerName ownerId-                appendTx <--                    prepareJournalAppend-                        ownerName-                        ownerId-                        gen-                        StepRecorded-                            { stepName = awakeableStepPrefix <> awakeableIdText aid-                            , result = payloadValue-                            , recordedAt = now-                            }-                (transitioned, appendOutcome) <--                    runTransaction $ do-                        transitioned <--                            if row ^. #status == Pending-                                then completeAwakeableTx (awakeableIdToUuid aid) (toJSON result) now-                                else pure False-                        if transitioned || row ^. #status == Completed-                            then do-                                outcome <- appendTx-                                condemnOnAppendConflict outcome-                                pure (transitioned, Just outcome)-                            else-                                lookupAwakeableStatusTx (awakeableIdToUuid aid) >>= \case-                                    Just Completed -> do-                                        outcome <- appendTx-                                        condemnOnAppendConflict outcome-                                        pure (False, Just outcome)-                                    _ -> pure (False, Nothing)-                for_ appendOutcome throwOnAppendConflict-                pure transitioned+  | row ^. #status == Cancelled = pure False+  | otherwise = do+      now <- liftIO getCurrentTime+      let aid = AwakeableId (row ^. #awakeableId)+          payload =+            if row ^. #status == Completed+              then row ^. #payload+              else Just (toJSON result)+      case payload of+        Nothing -> pure False+        Just payloadValue -> do+          let ownerName = WorkflowName (row ^. #ownerWorkflowName)+              ownerId = WorkflowId (row ^. #ownerWorkflowId)+          gen <- currentGeneration ownerName ownerId+          appendTx <-+            prepareJournalAppend+              ownerName+              ownerId+              gen+              StepRecorded+                { stepName = awakeableStepPrefix <> awakeableIdText aid,+                  result = payloadValue,+                  recordedAt = now+                }+          (transitioned, appendOutcome) <-+            runTransaction $ do+              transitioned <-+                if row ^. #status == Pending+                  then completeAwakeableTx (awakeableIdToUuid aid) (toJSON result) now+                  else pure False+              if transitioned || row ^. #status == Completed+                then do+                  outcome <- appendTx+                  condemnOnAppendConflict outcome+                  pure (transitioned, Just outcome)+                else+                  lookupAwakeableStatusTx (awakeableIdToUuid aid) >>= \case+                    Just Completed -> do+                      outcome <- appendTx+                      condemnOnAppendConflict outcome+                      pure (False, Just outcome)+                    _ -> pure (False, Nothing)+          for_ appendOutcome throwOnAppendConflict+          pure transitioned  condemnOnAppendConflict :: JournalAppendOutcome -> Tx.Transaction () condemnOnAppendConflict = \case-    JournalAppendConflict{} -> Tx.condemn-    _ -> pure ()+  JournalAppendConflict {} -> Tx.condemn+  _ -> pure ()  throwOnAppendConflict :: JournalAppendOutcome -> Eff es () throwOnAppendConflict = \case-    JournalAppendConflict err -> throwIO (WorkflowJournalAppendError (Text.pack (show err)))-    _ -> pure ()+  JournalAppendConflict err -> throwIO (WorkflowJournalAppendError (Text.pack (show err)))+  _ -> pure () -{- | Abandon a still-@pending@ awakeable: flips its row to @cancelled@ and-writes __no__ journal entry (there is no result value to record). Returns 'True'-when it transitioned a @pending@ row, 'False' otherwise (already completed,-already cancelled, or unknown). A workflow that later re-enters the awakeable's-@await@ then throws 'WorkflowAwakeableCancelled'.--}+-- | Abandon a still-@pending@ awakeable: flips its row to @cancelled@ and+-- writes __no__ journal entry (there is no result value to record). Returns 'True'+-- when it transitioned a @pending@ row, 'False' otherwise (already completed,+-- already cancelled, or unknown). A workflow that later re-enters the awakeable's+-- @await@ then throws 'WorkflowAwakeableCancelled'. cancelAwakeable :: (Store :> es) => AwakeableId -> Eff es Bool cancelAwakeable aid =-    runTransaction $ cancelAwakeableTx (awakeableIdToUuid aid)+  runTransaction $ cancelAwakeableTx (awakeableIdToUuid aid)
src/Keiro/Workflow/Awakeable/Schema.hs view
@@ -1,25 +1,24 @@-{- | The @keiro_awakeables@ table: durable storage for awakeables (external-promises a workflow suspends on).--Mirrors the @Keiro.Timer@ \/ @Keiro.Timer.Schema@ split: this module owns the-row type, the 'AwakeableStatus' lifecycle, and the hasql statements;-"Keiro.Workflow.Awakeable" owns the effectful authoring\/completion surface.--* 'registerAwakeableTx' inserts a @pending@ row idempotently (the-  @ON CONFLICT DO NOTHING@ EP-38's @awaitStep@ arming contract requires).-* 'lookupAwakeable' reads a row back.-* 'completeAwakeableTx' transitions a @pending@ row to @completed@ (guarded so-  a double signal is a no-op), and 'cancelAwakeableTx' transitions it to-  @cancelled@.-* 'countPendingAwakeables' counts outstanding promises — the seam EP-44 reads-  for its @keiro.workflow.awakeables.pending@ gauge.--Callers normally use the re-exports / surface from "Keiro.Workflow.Awakeable"-rather than this module directly; EP-44 imports 'countPendingAwakeables' here-without pulling in the effect surface.--}-module Keiro.Workflow.Awakeable.Schema (-    -- * Rows and status+-- | The @keiro_awakeables@ table: durable storage for awakeables (external+-- promises a workflow suspends on).+--+-- Mirrors the @Keiro.Timer@ \/ @Keiro.Timer.Schema@ split: this module owns the+-- row type, the 'AwakeableStatus' lifecycle, and the hasql statements;+-- "Keiro.Workflow.Awakeable" owns the effectful authoring\/completion surface.+--+-- * 'registerAwakeableTx' inserts a @pending@ row idempotently (the+--   @ON CONFLICT DO NOTHING@ EP-38's @awaitStep@ arming contract requires).+-- * 'lookupAwakeable' reads a row back.+-- * 'completeAwakeableTx' transitions a @pending@ row to @completed@ (guarded so+--   a double signal is a no-op), and 'cancelAwakeableTx' transitions it to+--   @cancelled@.+-- * 'countPendingAwakeables' counts outstanding promises — the seam EP-44 reads+--   for its @keiro.workflow.awakeables.pending@ gauge.+--+-- Callers normally use the re-exports / surface from "Keiro.Workflow.Awakeable"+-- rather than this module directly; EP-44 imports 'countPendingAwakeables' here+-- without pulling in the effect surface.+module Keiro.Workflow.Awakeable.Schema+  ( -- * Rows and status     AwakeableStatus (..),     AwakeableRow (..),     statusToText,@@ -34,7 +33,7 @@     -- * Read-only lookups     lookupAwakeable,     countPendingAwakeables,-)+  ) where  import Contravariant.Extras (contrazip3)@@ -48,187 +47,180 @@ import Kiroku.Store.Transaction (runTransaction) import "hasql-transaction" Hasql.Transaction qualified as Tx -{- | An awakeable's lifecycle state.--* 'Pending' — allocated and waiting for an external signal; the workflow is-  suspended on it.-* 'Completed' — signalled with a payload; terminal.-* 'Cancelled' — abandoned before it was signalled; terminal; also the decode-  fallback for an unrecognized stored value (the same defensive choice-  "Keiro.Timer.Schema" makes).--}+-- | An awakeable's lifecycle state.+--+-- * 'Pending' — allocated and waiting for an external signal; the workflow is+--   suspended on it.+-- * 'Completed' — signalled with a payload; terminal.+-- * 'Cancelled' — abandoned before it was signalled; terminal; also the decode+--   fallback for an unrecognized stored value (the same defensive choice+--   "Keiro.Timer.Schema" makes). data AwakeableStatus-    = Pending-    | Completed-    | Cancelled-    deriving stock (Generic, Eq, Show)+  = Pending+  | Completed+  | Cancelled+  deriving stock (Generic, Eq, Show) -{- | An awakeable row as stored: the deterministic id, the owning workflow's-name and instance id, the live 'status', the signalled 'payload' (JSON, set-only once 'Completed'), and the timestamps.--}+-- | An awakeable row as stored: the deterministic id, the owning workflow's+-- name and instance id, the live 'status', the signalled 'payload' (JSON, set+-- only once 'Completed'), and the timestamps. data AwakeableRow = AwakeableRow-    { awakeableId :: !UUID-    , ownerWorkflowName :: !Text-    , ownerWorkflowId :: !Text-    , status :: !AwakeableStatus-    , payload :: !(Maybe Value)-    , createdAt :: !UTCTime-    , updatedAt :: !UTCTime-    , completedAt :: !(Maybe UTCTime)-    }-    deriving stock (Generic, Eq, Show)+  { awakeableId :: !UUID,+    ownerWorkflowName :: !Text,+    ownerWorkflowId :: !Text,+    status :: !AwakeableStatus,+    payload :: !(Maybe Value),+    createdAt :: !UTCTime,+    updatedAt :: !UTCTime,+    completedAt :: !(Maybe UTCTime)+  }+  deriving stock (Generic, Eq, Show) -{- | Insert a @pending@ awakeable row inside the caller's transaction.-Idempotent by @ON CONFLICT (awakeable_id) DO NOTHING@ — exactly what EP-38's-"arm must be idempotent" contract needs, since a resumed workflow re-runs the-arming action on every resume until the awakeable resolves.--}+-- | Insert a @pending@ awakeable row inside the caller's transaction.+-- Idempotent by @ON CONFLICT (awakeable_id) DO NOTHING@ — exactly what EP-38's+-- "arm must be idempotent" contract needs, since a resumed workflow re-runs the+-- arming action on every resume until the awakeable resolves. registerAwakeableTx :: UUID -> Text -> Text -> Tx.Transaction () registerAwakeableTx aid name wid =-    Tx.statement (aid, name, wid) registerAwakeableStmt+  Tx.statement (aid, name, wid) registerAwakeableStmt -{- | Transition a @pending@ awakeable to @completed@, storing @payload@ and the-completion time, inside the caller's transaction. The @status = 'pending'@-guard makes a double-signal a no-op; returns 'True' only when this call-performed the transition (so the caller knows whether it was the one that-resolved the promise).--}+-- | Transition a @pending@ awakeable to @completed@, storing @payload@ and the+-- completion time, inside the caller's transaction. The @status = 'pending'@+-- guard makes a double-signal a no-op; returns 'True' only when this call+-- performed the transition (so the caller knows whether it was the one that+-- resolved the promise). completeAwakeableTx :: UUID -> Value -> UTCTime -> Tx.Transaction Bool completeAwakeableTx aid result now =-    Tx.statement (aid, result, now) completeAwakeableStmt+  Tx.statement (aid, result, now) completeAwakeableStmt -{- | Transition a @pending@ awakeable to @cancelled@ inside the caller's-transaction. Only @pending@ rows match, so an already-completed (or-already-cancelled) awakeable is left untouched and the call returns 'False'.--}+-- | Transition a @pending@ awakeable to @cancelled@ inside the caller's+-- transaction. Only @pending@ rows match, so an already-completed (or+-- already-cancelled) awakeable is left untouched and the call returns 'False'. cancelAwakeableTx :: UUID -> Tx.Transaction Bool cancelAwakeableTx aid =-    Tx.statement aid cancelAwakeableStmt+  Tx.statement aid cancelAwakeableStmt -{- | Read an awakeable's current status inside the caller's transaction.-Used after a guarded completion loses a row race, so the caller can distinguish-a winning cancel (no journal append) from a winning signal (idempotent repair).--}+-- | Read an awakeable's current status inside the caller's transaction.+-- Used after a guarded completion loses a row race, so the caller can distinguish+-- a winning cancel (no journal append) from a winning signal (idempotent repair). lookupAwakeableStatusTx :: UUID -> Tx.Transaction (Maybe AwakeableStatus) lookupAwakeableStatusTx aid =-    Tx.statement aid lookupAwakeableStatusStmt+  Tx.statement aid lookupAwakeableStatusStmt  -- | Read an awakeable row by id. 'Nothing' if no such awakeable exists. lookupAwakeable :: (Store :> es) => UUID -> Eff es (Maybe AwakeableRow) lookupAwakeable aid =-    runTransaction (Tx.statement aid lookupAwakeableStmt)+  runTransaction (Tx.statement aid lookupAwakeableStmt) -{- | Count awakeables currently @pending@. Read-only. EP-44 backs the-@keiro.workflow.awakeables.pending@ gauge with this.--}+-- | Count awakeables currently @pending@. Read-only. EP-44 backs the+-- @keiro.workflow.awakeables.pending@ gauge with this. countPendingAwakeables :: (Store :> es) => Eff es Int countPendingAwakeables =-    runTransaction (Tx.statement () countPendingAwakeablesStmt)+  runTransaction (Tx.statement () countPendingAwakeablesStmt)  registerAwakeableStmt :: Statement (UUID, Text, Text) () registerAwakeableStmt =-    preparable-        """-        INSERT INTO keiro.keiro_awakeables-          (awakeable_id, owner_workflow_name, owner_workflow_id, status)-        VALUES ($1, $2, $3, 'pending')-        ON CONFLICT (awakeable_id) DO NOTHING-        """-        ( contrazip3-            (E.param (E.nonNullable E.uuid))-            (E.param (E.nonNullable E.text))-            (E.param (E.nonNullable E.text))-        )-        D.noResult+  preparable+    """+    INSERT INTO keiro.keiro_awakeables+      (awakeable_id, owner_workflow_name, owner_workflow_id, status)+    VALUES ($1, $2, $3, 'pending')+    ON CONFLICT (awakeable_id) DO NOTHING+    """+    ( contrazip3+        (E.param (E.nonNullable E.uuid))+        (E.param (E.nonNullable E.text))+        (E.param (E.nonNullable E.text))+    )+    D.noResult  completeAwakeableStmt :: Statement (UUID, Value, UTCTime) Bool completeAwakeableStmt =-    preparable-        """-        UPDATE keiro.keiro_awakeables-        SET status = 'completed',-            payload = $2,-            completed_at = $3,-            updated_at = now()-        WHERE awakeable_id = $1-          AND status = 'pending'-        """-        ( contrazip3-            (E.param (E.nonNullable E.uuid))-            (E.param (E.nonNullable E.jsonb))-            (E.param (E.nonNullable E.timestamptz))-        )-        ((> 0) <$> D.rowsAffected)+  preparable+    """+    UPDATE keiro.keiro_awakeables+    SET status = 'completed',+        payload = $2,+        completed_at = $3,+        updated_at = now()+    WHERE awakeable_id = $1+      AND status = 'pending'+    """+    ( contrazip3+        (E.param (E.nonNullable E.uuid))+        (E.param (E.nonNullable E.jsonb))+        (E.param (E.nonNullable E.timestamptz))+    )+    ((> 0) <$> D.rowsAffected)  cancelAwakeableStmt :: Statement UUID Bool cancelAwakeableStmt =-    preparable-        """-        UPDATE keiro.keiro_awakeables-        SET status = 'cancelled',-            updated_at = now()-        WHERE awakeable_id = $1-          AND status = 'pending'-        """-        (E.param (E.nonNullable E.uuid))-        ((> 0) <$> D.rowsAffected)+  preparable+    """+    UPDATE keiro.keiro_awakeables+    SET status = 'cancelled',+        updated_at = now()+    WHERE awakeable_id = $1+      AND status = 'pending'+    """+    (E.param (E.nonNullable E.uuid))+    ((> 0) <$> D.rowsAffected)  lookupAwakeableStatusStmt :: Statement UUID (Maybe AwakeableStatus) lookupAwakeableStatusStmt =-    preparable-        """-        SELECT status-        FROM keiro.keiro_awakeables-        WHERE awakeable_id = $1-        """-        (E.param (E.nonNullable E.uuid))-        (D.rowMaybe (statusFromText <$> D.column (D.nonNullable D.text)))+  preparable+    """+    SELECT status+    FROM keiro.keiro_awakeables+    WHERE awakeable_id = $1+    """+    (E.param (E.nonNullable E.uuid))+    (D.rowMaybe (statusFromText <$> D.column (D.nonNullable D.text)))  lookupAwakeableStmt :: Statement UUID (Maybe AwakeableRow) lookupAwakeableStmt =-    preparable-        """-        SELECT awakeable_id, owner_workflow_name, owner_workflow_id, status,-          payload, created_at, updated_at, completed_at-        FROM keiro.keiro_awakeables-        WHERE awakeable_id = $1-        """-        (E.param (E.nonNullable E.uuid))-        (D.rowMaybe awakeableRowDecoder)+  preparable+    """+    SELECT awakeable_id, owner_workflow_name, owner_workflow_id, status,+      payload, created_at, updated_at, completed_at+    FROM keiro.keiro_awakeables+    WHERE awakeable_id = $1+    """+    (E.param (E.nonNullable E.uuid))+    (D.rowMaybe awakeableRowDecoder)  countPendingAwakeablesStmt :: Statement () Int countPendingAwakeablesStmt =-    preparable-        """-        SELECT count(*)-        FROM keiro.keiro_awakeables-        WHERE status = 'pending'-        """-        E.noParams-        (D.singleRow (fromIntegral <$> D.column (D.nonNullable D.int8)))+  preparable+    """+    SELECT count(*)+    FROM keiro.keiro_awakeables+    WHERE status = 'pending'+    """+    E.noParams+    (D.singleRow (fromIntegral <$> D.column (D.nonNullable D.int8)))  awakeableRowDecoder :: D.Row AwakeableRow awakeableRowDecoder =-    AwakeableRow-        <$> D.column (D.nonNullable D.uuid)-        <*> D.column (D.nonNullable D.text)-        <*> D.column (D.nonNullable D.text)-        <*> (statusFromText <$> D.column (D.nonNullable D.text))-        <*> D.column (D.nullable D.jsonb)-        <*> D.column (D.nonNullable D.timestamptz)-        <*> D.column (D.nonNullable D.timestamptz)-        <*> D.column (D.nullable D.timestamptz)+  AwakeableRow+    <$> D.column (D.nonNullable D.uuid)+    <*> D.column (D.nonNullable D.text)+    <*> D.column (D.nonNullable D.text)+    <*> (statusFromText <$> D.column (D.nonNullable D.text))+    <*> D.column (D.nullable D.jsonb)+    <*> D.column (D.nonNullable D.timestamptz)+    <*> D.column (D.nonNullable D.timestamptz)+    <*> D.column (D.nullable D.timestamptz)  statusToText :: AwakeableStatus -> Text statusToText = \case-    Pending -> "pending"-    Completed -> "completed"-    Cancelled -> "cancelled"+  Pending -> "pending"+  Completed -> "completed"+  Cancelled -> "cancelled"  statusFromText :: Text -> AwakeableStatus statusFromText = \case-    "pending" -> Pending-    "completed" -> Completed-    "cancelled" -> Cancelled-    _ -> Cancelled+  "pending" -> Pending+  "completed" -> Completed+  "cancelled" -> Cancelled+  _ -> Cancelled
src/Keiro/Workflow/Child.hs view
@@ -1,64 +1,63 @@-{- | Child workflows: spawn, wait on, and cancel a workflow from inside another.--== What this gives you--Fan-out\/fan-in composition of durable workflows. A /parent/ workflow spawns a-/child/ (a second workflow with its own journal stream), waits for the child's-result, and may cancel a child it no longer needs — with the whole relationship-surviving a crash, because the spawn is recorded in the parent's journal and the-link is stored in @keiro_workflow_children@.--@-parent :: ('Workflow' ':>' es, 'Store' ':>' es, 'IOE' ':>' es) => Eff es Text-parent = do-  h      <- 'spawnChild' (WorkflowName \"ship-order\") (WorkflowId \"ord-7\") shipWorkflow-  result <- 'awaitChild' h                  -- SUSPEND until the child completes-  _      <- 'Keiro.Workflow.step' (StepName \"notify\") (pure (\"shipped: \" <> result))-  pure result-@--== How it works (contract recap for downstream plans)--* __'spawnChild' is a journaled step.__ It records a @StepRecorded-  \"child:\<childId\>\"@ in the /parent/ journal (so a replay short-circuits the-  spawn and never re-spawns) and inserts a @running@ row in-  @keiro_workflow_children@ linking the child back to the parent plus the-  parent-journal step the parent awaits (@child:\<childId\>:result@). It does-  __not__ run the child inline — the EP-42 resume worker drives the child to-  completion from the application's @WorkflowRegistry@, so __a child's-  'WorkflowName' must be registered there__, exactly like any resumable-  workflow. (The @childDef@ argument is taken for authoring ergonomics; the-  registry, keyed by 'WorkflowName', is the source of truth for the child's-  body.)-* __'awaitChild' reuses EP-38's suspension primitive__ — it is-  @'awaitStep' (StepName \"child:\<childId\>:result\") arm@. On the miss path it-  re-delivers a completed child's stored result onto the current parent-  generation (attach semantics), throws 'WorkflowChildCancelled' if the child-  was cancelled meanwhile, throws 'WorkflowChildFailed' from the durable child-  row if it failed, and otherwise re-asserts nothing new (the spawn already-  registered the link). On the hit path-  it decodes a tagged parent-journal envelope: @{"ok": result}@ returns the-  child result, @{"cancelled": true}@ throws 'WorkflowChildCancelled',-  @{"failed": reason}@ throws 'WorkflowChildFailed', and legacy raw values are-  still decoded as pre-envelope successful results.-* __'runChildWorkflow'__ is what the resume worker selects (instead of bare-  'Keiro.Workflow.runWorkflowWith') for any workflow that is some parent's child:-  on 'Completed' it runs 'childCompletionHook', which flips the child row to-  @completed@ and appends @{"ok": result}@ to the parent's-  @child:\<childId\>:result@ step. If it finds a historically-  @cancelled@-but-unmarked row, it ensures the child cancellation marker and-  parent sentinel before returning 'Cancelled'.-* __'cancelChild'__ flips the child row to @cancelled@ and, in the same-  transaction, writes a 'Keiro.Workflow.WorkflowCancelled' marker to the-  /child/ journal plus a @{"cancelled": true}@ sentinel as the parent's-  await-step result. Retrying after a historical row-only cancel repairs both-  markers even though the return value remains 'False' ("this call did not-  transition the row").-* @'Keiro.Workflow.Child.Schema.countActiveChildren'@ backs a potential-  @keiro.workflow.children.active@ gauge for EP-44.--}-module Keiro.Workflow.Child (-    -- * Child handles and reserved step names+-- | Child workflows: spawn, wait on, and cancel a workflow from inside another.+--+-- == What this gives you+--+-- Fan-out\/fan-in composition of durable workflows. A /parent/ workflow spawns a+-- /child/ (a second workflow with its own journal stream), waits for the child's+-- result, and may cancel a child it no longer needs — with the whole relationship+-- surviving a crash, because the spawn is recorded in the parent's journal and the+-- link is stored in @keiro_workflow_children@.+--+-- @+-- parent :: ('Workflow' ':>' es, 'Store' ':>' es, 'IOE' ':>' es) => Eff es Text+-- parent = do+--   h      <- 'spawnChild' (WorkflowName \"ship-order\") (WorkflowId \"ord-7\") shipWorkflow+--   result <- 'awaitChild' h                  -- SUSPEND until the child completes+--   _      <- 'Keiro.Workflow.step' (StepName \"notify\") (pure (\"shipped: \" <> result))+--   pure result+-- @+--+-- == How it works (contract recap for downstream plans)+--+-- * __'spawnChild' is a journaled step.__ It records a @StepRecorded+--   \"child:\<childId\>\"@ in the /parent/ journal (so a replay short-circuits the+--   spawn and never re-spawns) and inserts a @running@ row in+--   @keiro_workflow_children@ linking the child back to the parent plus the+--   parent-journal step the parent awaits (@child:\<childId\>:result@). It does+--   __not__ run the child inline — the EP-42 resume worker drives the child to+--   completion from the application's @WorkflowRegistry@, so __a child's+--   'WorkflowName' must be registered there__, exactly like any resumable+--   workflow. (The @childDef@ argument is taken for authoring ergonomics; the+--   registry, keyed by 'WorkflowName', is the source of truth for the child's+--   body.)+-- * __'awaitChild' reuses EP-38's suspension primitive__ — it is+--   @'awaitStep' (StepName \"child:\<childId\>:result\") arm@. On the miss path it+--   re-delivers a completed child's stored result onto the current parent+--   generation (attach semantics), throws 'WorkflowChildCancelled' if the child+--   was cancelled meanwhile, throws 'WorkflowChildFailed' from the durable child+--   row if it failed, and otherwise re-asserts nothing new (the spawn already+--   registered the link). On the hit path+--   it decodes a tagged parent-journal envelope: @{"ok": result}@ returns the+--   child result, @{"cancelled": true}@ throws 'WorkflowChildCancelled',+--   @{"failed": reason}@ throws 'WorkflowChildFailed', and legacy raw values are+--   still decoded as pre-envelope successful results.+-- * __'runChildWorkflow'__ is what the resume worker selects (instead of bare+--   'Keiro.Workflow.runWorkflowWith') for any workflow that is some parent's child:+--   on 'Completed' it runs 'childCompletionHook', which flips the child row to+--   @completed@ and appends @{"ok": result}@ to the parent's+--   @child:\<childId\>:result@ step. If it finds a historically+--   @cancelled@-but-unmarked row, it ensures the child cancellation marker and+--   parent sentinel before returning 'Cancelled'.+-- * __'cancelChild'__ flips the child row to @cancelled@ and, in the same+--   transaction, writes a 'Keiro.Workflow.WorkflowCancelled' marker to the+--   /child/ journal plus a @{"cancelled": true}@ sentinel as the parent's+--   await-step result. Retrying after a historical row-only cancel repairs both+--   markers even though the return value remains 'False' ("this call did not+--   transition the row").+-- * @'Keiro.Workflow.Child.Schema.countActiveChildren'@ backs a potential+--   @keiro.workflow.children.active@ gauge for EP-44.+module Keiro.Workflow.Child+  ( -- * Child handles and reserved step names     ChildHandle (..),     childSpawnStepName,     childResultStepName,@@ -77,7 +76,7 @@     -- * Errors     WorkflowChildCancelled (..),     WorkflowChildFailed (..),-)+  ) where  import Control.Exception (Exception)@@ -88,8 +87,8 @@ import Effectful.Error.Static (Error) import Effectful.Exception (throwIO) import Keiro.Prelude-import Keiro.Workflow (-    JournalAppendOutcome (..),+import Keiro.Workflow+  ( JournalAppendOutcome (..),     StepName (..),     Workflow,     WorkflowError (..),@@ -106,15 +105,15 @@     prepareJournalAppend,     runWorkflowWith,     step,- )-import Keiro.Workflow.Child.Schema (-    ChildRow,+  )+import Keiro.Workflow.Child.Schema+  ( ChildRow,     ChildStatus (..),     lookupChild,     markChildCancelledTx,     markChildResultTx,     registerChildTx,- )+  ) import Keiro.Workflow.Instance (WorkflowStatus (..), lookupInstance, upsertInstanceTx) import Kiroku.Store.Effect (Store) import Kiroku.Store.Error (StoreError)@@ -125,27 +124,24 @@ -- Handles and reserved step names -- --------------------------------------------------------------------------- -{- | An in-memory handle to a spawned child, returned by 'spawnChild' and taken-by 'awaitChild' \/ 'cancelChild'. The phantom type parameter @a@ records the-child's result type so 'awaitChild' decodes without an extra annotation; the-handle itself carries only the child's name and id (the child journal is-@wf:\<childName\>-\<childWfId\>@).--}+-- | An in-memory handle to a spawned child, returned by 'spawnChild' and taken+-- by 'awaitChild' \/ 'cancelChild'. The phantom type parameter @a@ records the+-- child's result type so 'awaitChild' decodes without an extra annotation; the+-- handle itself carries only the child's name and id (the child journal is+-- @wf:\<childName\>-\<childWfId\>@). data ChildHandle a = ChildHandle-    { childName :: !WorkflowName-    , childWfId :: !WorkflowId-    }-    deriving stock (Eq, Show)+  { childName :: !WorkflowName,+    childWfId :: !WorkflowId+  }+  deriving stock (Eq, Show) -{- | The reserved /spawn/ step name a child is recorded under in its parent's-journal: @child:\<childId\>@ (uses EP-38's 'childStepPrefix').--}+-- | The reserved /spawn/ step name a child is recorded under in its parent's+-- journal: @child:\<childId\>@ (uses EP-38's 'childStepPrefix'). childSpawnStepName :: WorkflowId -> Text childSpawnStepName (WorkflowId wid) = childStepPrefix <> wid -{- | The reserved /result/ step name the parent awaits and the child's-completion is propagated under: @child:\<childId\>:result@.--}+-- | The reserved /result/ step name the parent awaits and the child's+-- completion is propagated under: @child:\<childId\>:result@. childResultStepName :: WorkflowId -> Text childResultStepName (WorkflowId wid) = childStepPrefix <> wid <> ":result" @@ -153,23 +149,21 @@ -- Errors -- --------------------------------------------------------------------------- -{- | Thrown out of 'awaitChild' when the awaited child was 'cancelChild'led. A-cancelled child never produces a result, so suspending forever would be wrong-and fabricating a result would be wrong; the parent author can @catch@ this to-run compensation. If uncaught, the resume worker records the parent attempt,-backs it off, and eventually marks the parent failed at its configured ceiling.-Mirrors EP-40's 'Keiro.Workflow.Awakeable.WorkflowAwakeableCancelled'.--}+-- | Thrown out of 'awaitChild' when the awaited child was 'cancelChild'led. A+-- cancelled child never produces a result, so suspending forever would be wrong+-- and fabricating a result would be wrong; the parent author can @catch@ this to+-- run compensation. If uncaught, the resume worker records the parent attempt,+-- backs it off, and eventually marks the parent failed at its configured ceiling.+-- Mirrors EP-40's 'Keiro.Workflow.Awakeable.WorkflowAwakeableCancelled'. data WorkflowChildCancelled = WorkflowChildCancelled WorkflowName WorkflowId-    deriving stock (Eq, Show)+  deriving stock (Eq, Show)  instance Exception WorkflowChildCancelled -{- | Thrown out of 'awaitChild' when the child was terminally failed by the-resume worker. Carries the child's identity plus the persisted failure reason.--}+-- | Thrown out of 'awaitChild' when the child was terminally failed by the+-- resume worker. Carries the child's identity plus the persisted failure reason. data WorkflowChildFailed = WorkflowChildFailed WorkflowName WorkflowId Text-    deriving stock (Eq, Show)+  deriving stock (Eq, Show)  instance Exception WorkflowChildFailed @@ -177,272 +171,266 @@ -- Authoring surface -- --------------------------------------------------------------------------- -{- | Spawn a child workflow. Records a @StepRecorded \"child:\<childId\>\"@ in-the /parent/ journal (so a replay short-circuits and never re-spawns) and-inserts an idempotent @running@ link row, then returns a 'ChildHandle'. The-child is driven to completion by the resume worker from the registry, so-@childNm@ __must be registered there__; @childDef@ is accepted for authoring-ergonomics but is not run here.--A child id names one execution globally. Spawning an id whose child row already-completed attaches to that execution: 'awaitChild' re-delivers the stored-result onto the parent's current generation. To run a fresh child after-'Keiro.Workflow.continueAsNew', derive a fresh child id from the carried seed.--}+-- | Spawn a child workflow. Records a @StepRecorded \"child:\<childId\>\"@ in+-- the /parent/ journal (so a replay short-circuits and never re-spawns) and+-- inserts an idempotent @running@ link row, then returns a 'ChildHandle'. The+-- child is driven to completion by the resume worker from the registry, so+-- @childNm@ __must be registered there__; @childDef@ is accepted for authoring+-- ergonomics but is not run here.+--+-- A child id names one execution globally. Spawning an id whose child row already+-- completed attaches to that execution: 'awaitChild' re-delivers the stored+-- result onto the parent's current generation. To run a fresh child after+-- 'Keiro.Workflow.continueAsNew', derive a fresh child id from the carried seed. spawnChild ::-    (Workflow :> es, Store :> es) =>-    -- | The child's name (must be in the resume worker's registry).-    WorkflowName ->-    -- | The child's id (names the child journal).-    WorkflowId ->-    -- | The child workflow definition (for authoring; the registry actually runs it).-    Eff (Workflow : es) a ->-    Eff es (ChildHandle a)+  (Workflow :> es, Store :> es) =>+  -- | The child's name (must be in the resume worker's registry).+  WorkflowName ->+  -- | The child's id (names the child journal).+  WorkflowId ->+  -- | The child workflow definition (for authoring; the registry actually runs it).+  Eff (Workflow : es) a ->+  Eff es (ChildHandle a) spawnChild childNm childWid _childDef = do-    (parentNm, parentWid) <- currentWorkflow-    let spawnStep = StepName (childSpawnStepName childWid)-        resultStep = childResultStepName childWid-    -- Journaled as a step in the PARENT journal: a parent replay short-circuits-    -- this body, and the ON CONFLICT DO NOTHING register collapses on re-run.-    _ <--        step spawnStep $ do-            runTransaction $-                registerChildTx-                    (unWorkflowId childWid)-                    (unWorkflowName childNm)-                    (unWorkflowId parentWid)-                    (unWorkflowName parentNm)-                    resultStep-                    *> upsertInstanceTx-                        (unWorkflowId childWid)-                        (unWorkflowName childNm)-                        0-                        WfRunning-                        Nothing-            pure ()-    pure (ChildHandle childNm childWid)--{- | Suspend the parent until the child completes, then return the child's-result. This is EP-38's 'awaitStep' on the @child:\<childId\>:result@ step:-'childCompletionHook' journals that step into the parent when the child-finishes, so the next parent run replays past the wait and decodes the result.+  (parentNm, parentWid) <- currentWorkflow+  let spawnStep = StepName (childSpawnStepName childWid)+      resultStep = childResultStepName childWid+  -- Journaled as a step in the PARENT journal: a parent replay short-circuits+  -- this body, and the ON CONFLICT DO NOTHING register collapses on re-run.+  _ <-+    step spawnStep $ do+      runTransaction $+        registerChildTx+          (unWorkflowId childWid)+          (unWorkflowName childNm)+          (unWorkflowId parentWid)+          (unWorkflowName parentNm)+          resultStep+          *> upsertInstanceTx+            (unWorkflowId childWid)+            (unWorkflowName childNm)+            0+            WfRunning+            Nothing+      pure ()+  pure (ChildHandle childNm childWid) -If the child was cancelled or failed, throws 'WorkflowChildCancelled' or-'WorkflowChildFailed'. Parent-journal values are tagged envelopes-(@{"ok": ...}@, @{"cancelled": true}@, @{"failed": reason}@) with a legacy raw-success fallback; a decode mismatch throws 'WorkflowStepDecodeError'.--}+-- | Suspend the parent until the child completes, then return the child's+-- result. This is EP-38's 'awaitStep' on the @child:\<childId\>:result@ step:+-- 'childCompletionHook' journals that step into the parent when the child+-- finishes, so the next parent run replays past the wait and decodes the result.+--+-- If the child was cancelled or failed, throws 'WorkflowChildCancelled' or+-- 'WorkflowChildFailed'. Parent-journal values are tagged envelopes+-- (@{"ok": ...}@, @{"cancelled": true}@, @{"failed": reason}@) with a legacy raw+-- success fallback; a decode mismatch throws 'WorkflowStepDecodeError'. awaitChild ::-    (Workflow :> es, Store :> es, IOE :> es, FromJSON a) =>-    ChildHandle a ->-    Eff es a+  (Workflow :> es, Store :> es, IOE :> es, FromJSON a) =>+  ChildHandle a ->+  Eff es a awaitChild (ChildHandle childNm childWid) = do-    let resultStep = StepName (childResultStepName childWid)-        arm = do-            mrow <- lookupChild (unWorkflowId childWid) (unWorkflowName childNm)-            case mrow of-                Just row-                    | (row ^. #status) == ChildCancelled ->-                        throwIO (WorkflowChildCancelled childNm childWid)-                    | (row ^. #status) == ChildFailed -> do-                        mInstance <- lookupInstance childNm childWid-                        let reason =-                                case row ^. #failureReason of-                                    Just recorded -> recorded-                                    Nothing ->-                                        fromMaybe-                                            "child workflow failed (reason not recorded)"-                                            (mInstance >>= (^. #lastError))-                        throwIO (WorkflowChildFailed childNm childWid reason)-                    | (row ^. #status) == ChildCompleted-                    , Just resultValue <- row ^. #result ->-                        appendJournalEntry-                            (WorkflowName (row ^. #parentName))-                            (WorkflowId (row ^. #parentId))-                            StepRecorded-                                { stepName = row ^. #awaitStep-                                , result = childOkEnvelope resultValue-                                , recordedAt = fromMaybe (row ^. #updatedAt) (row ^. #completedAt)-                                }-                -- The spawn already registered the link; nothing more to (re-)arm.-                _ -> pure ()-    raw <- awaitStep resultStep arm-    decodeChildResult childNm childWid (unStepName resultStep) raw+  let resultStep = StepName (childResultStepName childWid)+      arm = do+        mrow <- lookupChild (unWorkflowId childWid) (unWorkflowName childNm)+        case mrow of+          Just row+            | (row ^. #status) == ChildCancelled ->+                throwIO (WorkflowChildCancelled childNm childWid)+            | (row ^. #status) == ChildFailed -> do+                mInstance <- lookupInstance childNm childWid+                let reason =+                      case row ^. #failureReason of+                        Just recorded -> recorded+                        Nothing ->+                          fromMaybe+                            "child workflow failed (reason not recorded)"+                            (mInstance >>= (^. #lastError))+                throwIO (WorkflowChildFailed childNm childWid reason)+            | (row ^. #status) == ChildCompleted,+              Just resultValue <- row ^. #result ->+                appendJournalEntry+                  (WorkflowName (row ^. #parentName))+                  (WorkflowId (row ^. #parentId))+                  StepRecorded+                    { stepName = row ^. #awaitStep,+                      result = childOkEnvelope resultValue,+                      recordedAt = fromMaybe (row ^. #updatedAt) (row ^. #completedAt)+                    }+          -- The spawn already registered the link; nothing more to (re-)arm.+          _ -> pure ()+  raw <- awaitStep resultStep arm+  decodeChildResult childNm childWid (unStepName resultStep) raw  -- --------------------------------------------------------------------------- -- External control -- --------------------------------------------------------------------------- -{- | Cancel a child. For a @running@ child, flips its-@keiro_workflow_children@ row to @cancelled@ and, in the same transaction,-writes both the child's 'WorkflowCancelled' marker and the parent's-@{"cancelled": true}@ await-step sentinel. Returns 'True' only when this call-performed the row transition. For an already-@cancelled@ row, returns 'False'-but still ensures both markers, repairing historical crashes that committed the-row flip before either journal append. Already completed/failed/unknown-children return 'False' and no marker is fabricated.--}+-- | Cancel a child. For a @running@ child, flips its+-- @keiro_workflow_children@ row to @cancelled@ and, in the same transaction,+-- writes both the child's 'WorkflowCancelled' marker and the parent's+-- @{"cancelled": true}@ await-step sentinel. Returns 'True' only when this call+-- performed the row transition. For an already-@cancelled@ row, returns 'False'+-- but still ensures both markers, repairing historical crashes that committed the+-- row flip before either journal append. Already completed/failed/unknown+-- children return 'False' and no marker is fabricated. cancelChild ::-    (IOE :> es, Store :> es) =>-    ChildHandle a ->-    Eff es Bool+  (IOE :> es, Store :> es) =>+  ChildHandle a ->+  Eff es Bool cancelChild (ChildHandle childNm childWid) = do-    mrow <- lookupChild (unWorkflowId childWid) (unWorkflowName childNm)-    case mrow of-        Nothing -> pure False-        Just row -> do-            (transitioned, childOutcome, parentOutcome) <- ensureChildCancelled row-            throwOnAppendConflict childOutcome-            throwOnAppendConflict parentOutcome-            pure transitioned+  mrow <- lookupChild (unWorkflowId childWid) (unWorkflowName childNm)+  case mrow of+    Nothing -> pure False+    Just row -> do+      (transitioned, childOutcome, parentOutcome) <- ensureChildCancelled row+      throwOnAppendConflict childOutcome+      throwOnAppendConflict parentOutcome+      pure transitioned  -- --------------------------------------------------------------------------- -- Completion propagation -- --------------------------------------------------------------------------- -{- | Drive a child workflow to completion, propagating its result to the parent.-This is 'runWorkflowWith' followed by 'childCompletionHook' on 'Completed': the-resume worker selects this (instead of bare 'runWorkflowWith') for any workflow-that is some parent's child, so a finished child wakes its waiting parent. A-'Suspended' child propagates nothing. A child row already marked 'ChildCancelled'-is repaired by ensuring the child cancellation marker and parent sentinel, then-returns 'Cancelled'; a 'ChildFailed' row returns 'Failed'.--}+-- | Drive a child workflow to completion, propagating its result to the parent.+-- This is 'runWorkflowWith' followed by 'childCompletionHook' on 'Completed': the+-- resume worker selects this (instead of bare 'runWorkflowWith') for any workflow+-- that is some parent's child, so a finished child wakes its waiting parent. A+-- 'Suspended' child propagates nothing. A child row already marked 'ChildCancelled'+-- is repaired by ensuring the child cancellation marker and parent sentinel, then+-- returns 'Cancelled'; a 'ChildFailed' row returns 'Failed'. runChildWorkflow ::-    (IOE :> es, Store :> es, Error StoreError :> es, ToJSON a) =>-    WorkflowRunOptions ->-    WorkflowName ->-    WorkflowId ->-    Eff (Workflow : es) a ->-    Eff es (WorkflowOutcome a)+  (IOE :> es, Store :> es, Error StoreError :> es, ToJSON a) =>+  WorkflowRunOptions ->+  WorkflowName ->+  WorkflowId ->+  Eff (Workflow : es) a ->+  Eff es (WorkflowOutcome a) runChildWorkflow opts childNm childWid action = do-    mrow <- lookupChild (unWorkflowId childWid) (unWorkflowName childNm)-    case fmap (^. #status) mrow of-        Just ChildCancelled -> do-            for_ mrow $ \row -> do-                (_, childOutcome, parentOutcome) <- ensureChildCancelled row-                throwOnAppendConflict childOutcome-                throwOnAppendConflict parentOutcome-            pure Cancelled-        Just ChildFailed -> pure Failed-        _ -> do-            outcome <- runWorkflowWith opts childNm childWid action-            case outcome of-                Completed result -> do-                    childCompletionHook childNm childWid (toJSON result)-                    pure (Completed result)-                other -> pure other+  mrow <- lookupChild (unWorkflowId childWid) (unWorkflowName childNm)+  case fmap (^. #status) mrow of+    Just ChildCancelled -> do+      for_ mrow $ \row -> do+        (_, childOutcome, parentOutcome) <- ensureChildCancelled row+        throwOnAppendConflict childOutcome+        throwOnAppendConflict parentOutcome+      pure Cancelled+    Just ChildFailed -> pure Failed+    _ -> do+      outcome <- runWorkflowWith opts childNm childWid action+      case outcome of+        Completed result -> do+          childCompletionHook childNm childWid (toJSON result)+          pure (Completed result)+        other -> pure other -{- | Propagate a finished child's result to its parent: flip the child row to-@completed@ (storing the raw result in the child row) and append an-@{"ok": result}@ @child:\<childId\>:result@ 'StepRecorded' to the /parent/-journal — exactly the wake source the parent's 'awaitChild' resolves on. The-running-row transition and parent append happen in one transaction. An-already-@completed@ row re-appends from the stored result, repairing historical-wedges; cancelled/failed children do not fabricate a success. Normally invoked-via 'runChildWorkflow'.--}+-- | Propagate a finished child's result to its parent: flip the child row to+-- @completed@ (storing the raw result in the child row) and append an+-- @{"ok": result}@ @child:\<childId\>:result@ 'StepRecorded' to the /parent/+-- journal — exactly the wake source the parent's 'awaitChild' resolves on. The+-- running-row transition and parent append happen in one transaction. An+-- already-@completed@ row re-appends from the stored result, repairing historical+-- wedges; cancelled/failed children do not fabricate a success. Normally invoked+-- via 'runChildWorkflow'. childCompletionHook ::-    (IOE :> es, Store :> es) =>-    WorkflowName ->-    WorkflowId ->-    Aeson.Value ->-    Eff es ()+  (IOE :> es, Store :> es) =>+  WorkflowName ->+  WorkflowId ->+  Aeson.Value ->+  Eff es () childCompletionHook childNm childWid resultValue = do-    mrow <- lookupChild (unWorkflowId childWid) (unWorkflowName childNm)-    for_ mrow $ \row -> case row ^. #status of-        Running -> do-            now <- liftIO getCurrentTime-            let parentName = WorkflowName (row ^. #parentName)-                parentId = WorkflowId (row ^. #parentId)-            gen <- currentGeneration parentName parentId-            appendTx <--                prepareJournalAppend-                    parentName-                    parentId-                    gen-                    StepRecorded-                        { stepName = row ^. #awaitStep-                        , result = childOkEnvelope resultValue-                        , recordedAt = now-                        }-            appendOutcome <--                runTransaction $ do-                    transitioned <- markChildResultTx (unWorkflowId childWid) (unWorkflowName childNm) resultValue now-                    if transitioned-                        then do-                            appendOutcome <- appendTx-                            condemnOnAppendConflict appendOutcome-                            pure appendOutcome-                        else pure (JournalAlreadyPresent resultValue)-            throwOnAppendConflict appendOutcome-        ChildCompleted ->-            for_ (row ^. #result) $ \stored ->-                appendJournalEntry-                    (WorkflowName (row ^. #parentName))-                    (WorkflowId (row ^. #parentId))-                    StepRecorded-                        { stepName = row ^. #awaitStep-                        , result = childOkEnvelope stored-                        , recordedAt = fromMaybe (row ^. #updatedAt) (row ^. #completedAt)-                        }-        ChildCancelled -> pure ()-        ChildFailed -> pure ()+  mrow <- lookupChild (unWorkflowId childWid) (unWorkflowName childNm)+  for_ mrow $ \row -> case row ^. #status of+    Running -> do+      now <- liftIO getCurrentTime+      let parentName = WorkflowName (row ^. #parentName)+          parentId = WorkflowId (row ^. #parentId)+      gen <- currentGeneration parentName parentId+      appendTx <-+        prepareJournalAppend+          parentName+          parentId+          gen+          StepRecorded+            { stepName = row ^. #awaitStep,+              result = childOkEnvelope resultValue,+              recordedAt = now+            }+      appendOutcome <-+        runTransaction $ do+          transitioned <- markChildResultTx (unWorkflowId childWid) (unWorkflowName childNm) resultValue now+          if transitioned+            then do+              appendOutcome <- appendTx+              condemnOnAppendConflict appendOutcome+              pure appendOutcome+            else pure (JournalAlreadyPresent resultValue)+      throwOnAppendConflict appendOutcome+    ChildCompleted ->+      for_ (row ^. #result) $ \stored ->+        appendJournalEntry+          (WorkflowName (row ^. #parentName))+          (WorkflowId (row ^. #parentId))+          StepRecorded+            { stepName = row ^. #awaitStep,+              result = childOkEnvelope stored,+              recordedAt = fromMaybe (row ^. #updatedAt) (row ^. #completedAt)+            }+    ChildCancelled -> pure ()+    ChildFailed -> pure ()  condemnOnAppendConflict :: JournalAppendOutcome -> Tx.Transaction () condemnOnAppendConflict = \case-    JournalAppendConflict{} -> Tx.condemn-    _ -> pure ()+  JournalAppendConflict {} -> Tx.condemn+  _ -> pure ()  throwOnAppendConflict :: JournalAppendOutcome -> Eff es () throwOnAppendConflict = \case-    JournalAppendConflict err -> throwIO (WorkflowJournalAppendError (Text.pack (show err)))-    _ -> pure ()+  JournalAppendConflict err -> throwIO (WorkflowJournalAppendError (Text.pack (show err)))+  _ -> pure ()  ensureChildCancelled ::-    (IOE :> es, Store :> es) =>-    ChildRow ->-    Eff es (Bool, JournalAppendOutcome, JournalAppendOutcome)+  (IOE :> es, Store :> es) =>+  ChildRow ->+  Eff es (Bool, JournalAppendOutcome, JournalAppendOutcome) ensureChildCancelled row = do-    now <- liftIO getCurrentTime-    let childNm = WorkflowName (row ^. #childName)-        childWid = WorkflowId (row ^. #childId)-        parentNm = WorkflowName (row ^. #parentName)-        parentWid = WorkflowId (row ^. #parentId)-    childGen <- currentGeneration childNm childWid-    parentGen <- currentGeneration parentNm parentWid-    childAppendTx <- prepareJournalAppend childNm childWid childGen WorkflowCancelled{recordedAt = now}-    parentAppendTx <--        prepareJournalAppend-            parentNm-            parentWid-            parentGen-            StepRecorded-                { stepName = row ^. #awaitStep-                , result = cancelledSentinel-                , recordedAt = now-                }-    runTransaction $ do-        transitioned <--            if row ^. #status == Running-                then markChildCancelledTx (row ^. #childId) (row ^. #childName)-                else pure False-        if transitioned || row ^. #status == ChildCancelled-            then do-                childOutcome <- childAppendTx-                parentOutcome <- parentAppendTx-                condemnOnAppendConflict childOutcome-                condemnOnAppendConflict parentOutcome-                pure (transitioned, childOutcome, parentOutcome)-            else pure (False, JournalAlreadyPresent Aeson.Null, JournalAlreadyPresent Aeson.Null)+  now <- liftIO getCurrentTime+  let childNm = WorkflowName (row ^. #childName)+      childWid = WorkflowId (row ^. #childId)+      parentNm = WorkflowName (row ^. #parentName)+      parentWid = WorkflowId (row ^. #parentId)+  childGen <- currentGeneration childNm childWid+  parentGen <- currentGeneration parentNm parentWid+  childAppendTx <- prepareJournalAppend childNm childWid childGen WorkflowCancelled {recordedAt = now}+  parentAppendTx <-+    prepareJournalAppend+      parentNm+      parentWid+      parentGen+      StepRecorded+        { stepName = row ^. #awaitStep,+          result = cancelledSentinel,+          recordedAt = now+        }+  runTransaction $ do+    transitioned <-+      if row ^. #status == Running+        then markChildCancelledTx (row ^. #childId) (row ^. #childName)+        else pure False+    if transitioned || row ^. #status == ChildCancelled+      then do+        childOutcome <- childAppendTx+        parentOutcome <- parentAppendTx+        condemnOnAppendConflict childOutcome+        condemnOnAppendConflict parentOutcome+        pure (transitioned, childOutcome, parentOutcome)+      else pure (False, JournalAlreadyPresent Aeson.Null, JournalAlreadyPresent Aeson.Null)  -- --------------------------------------------------------------------------- -- The cancellation sentinel -- --------------------------------------------------------------------------- -{- | The @{"cancelled": true}@ value 'cancelChild' writes as a cancelled child's-await-step result so 'awaitChild' can detect it and throw.--}+-- | The @{"cancelled": true}@ value 'cancelChild' writes as a cancelled child's+-- await-step result so 'awaitChild' can detect it and throw. cancelledSentinel :: Aeson.Value cancelledSentinel = Aeson.object ["cancelled" Aeson..= True] @@ -450,24 +438,24 @@ childOkEnvelope value = Aeson.object ["ok" Aeson..= value]  decodeChildResult ::-    (FromJSON a) =>-    WorkflowName ->-    WorkflowId ->-    Text ->-    Aeson.Value ->-    Eff es a+  (FromJSON a) =>+  WorkflowName ->+  WorkflowId ->+  Text ->+  Aeson.Value ->+  Eff es a decodeChildResult childNm childWid key raw =-    case raw of-        Aeson.Object obj-            | Just okValue <- KeyMap.lookup "ok" obj ->-                decodeOrThrow okValue-            | Just (Aeson.Bool True) <- KeyMap.lookup "cancelled" obj ->-                throwIO (WorkflowChildCancelled childNm childWid)-            | Just (Aeson.String reason) <- KeyMap.lookup "failed" obj ->-                throwIO (WorkflowChildFailed childNm childWid reason)-        _ -> decodeOrThrow raw+  case raw of+    Aeson.Object obj+      | Just okValue <- KeyMap.lookup "ok" obj ->+          decodeOrThrow okValue+      | Just (Aeson.Bool True) <- KeyMap.lookup "cancelled" obj ->+          throwIO (WorkflowChildCancelled childNm childWid)+      | Just (Aeson.String reason) <- KeyMap.lookup "failed" obj ->+          throwIO (WorkflowChildFailed childNm childWid reason)+    _ -> decodeOrThrow raw   where     decodeOrThrow value =-        case Aeson.fromJSON value of-            Aeson.Success a -> pure a-            Aeson.Error e -> throwIO (WorkflowStepDecodeError key (Text.pack e))+      case Aeson.fromJSON value of+        Aeson.Success a -> pure a+        Aeson.Error e -> throwIO (WorkflowStepDecodeError key (Text.pack e))
src/Keiro/Workflow/Child/Schema.hs view
@@ -1,30 +1,29 @@-{- | The @keiro_workflow_children@ table: durable parent↔child workflow links.--Mirrors the @Keiro.Timer@ \/ @Keiro.Timer.Schema@ and-@Keiro.Workflow.Awakeable.Schema@ split: this module owns the row type, the-'ChildStatus' lifecycle, and the hasql statements; "Keiro.Workflow.Child" owns-the effectful spawn\/await\/cancel surface.--* 'registerChildTx' inserts a @running@ row idempotently (the-  @ON CONFLICT (child_id, child_name) DO NOTHING@ EP-38's @awaitStep@ arming-  contract requires — a resumed parent re-runs the arm on every resume).-* 'lookupChild' \/ 'lookupChildrenOfParent' read rows back (operator-  inspection and the @awaitChild@ arm's cancellation check).-* 'markChildResultTx' transitions a @running@ row to @completed@ (storing the-  child's result), 'markChildCancelledTx' transitions it to @cancelled@, and-  'markChildFailedTx' transitions it to @failed@ while preserving the reason;-  all guard on @status = 'running'@ so a double-resolve is a no-op.-* 'findRunningChildIds' is the resume worker's discovery seed for a zero-step-  child (one that has been spawned but not yet driven, so has no-  @keiro_workflow_steps@ rows for 'findUnfinishedWorkflowIds' to find).-* 'countActiveChildren' counts outstanding children — the seam EP-44 may read-  for a @keiro.workflow.children.active@ gauge.--Callers normally use the surface from "Keiro.Workflow.Child" rather than this-module directly.--}-module Keiro.Workflow.Child.Schema (-    -- * Rows and status+-- | The @keiro_workflow_children@ table: durable parent↔child workflow links.+--+-- Mirrors the @Keiro.Timer@ \/ @Keiro.Timer.Schema@ and+-- @Keiro.Workflow.Awakeable.Schema@ split: this module owns the row type, the+-- 'ChildStatus' lifecycle, and the hasql statements; "Keiro.Workflow.Child" owns+-- the effectful spawn\/await\/cancel surface.+--+-- * 'registerChildTx' inserts a @running@ row idempotently (the+--   @ON CONFLICT (child_id, child_name) DO NOTHING@ EP-38's @awaitStep@ arming+--   contract requires — a resumed parent re-runs the arm on every resume).+-- * 'lookupChild' \/ 'lookupChildrenOfParent' read rows back (operator+--   inspection and the @awaitChild@ arm's cancellation check).+-- * 'markChildResultTx' transitions a @running@ row to @completed@ (storing the+--   child's result), 'markChildCancelledTx' transitions it to @cancelled@, and+--   'markChildFailedTx' transitions it to @failed@ while preserving the reason;+--   all guard on @status = 'running'@ so a double-resolve is a no-op.+-- * 'findRunningChildIds' is the resume worker's discovery seed for a zero-step+--   child (one that has been spawned but not yet driven, so has no+--   @keiro_workflow_steps@ rows for 'findUnfinishedWorkflowIds' to find).+-- * 'countActiveChildren' counts outstanding children — the seam EP-44 may read+--   for a @keiro.workflow.children.active@ gauge.+--+-- Callers normally use the surface from "Keiro.Workflow.Child" rather than this+-- module directly.+module Keiro.Workflow.Child.Schema+  ( -- * Rows and status     ChildStatus (..),     ChildRow (..),     statusToText,@@ -43,7 +42,7 @@     childStatus,     countActiveChildren,     findRunningChildIds,-)+  ) where  import Contravariant.Extras (contrazip2, contrazip3, contrazip4, contrazip5)@@ -56,299 +55,290 @@ import Kiroku.Store.Transaction (runTransaction) import "hasql-transaction" Hasql.Transaction qualified as Tx -{- | A child workflow's lifecycle, as seen from its parent.--* 'Running' — spawned and not yet finished; the resume worker drives it.-* 'ChildCompleted' — the child reached its own 'Keiro.Workflow.WorkflowCompleted'-  and its result was propagated to the parent journal; terminal.-* 'ChildCancelled' — the parent 'Keiro.Workflow.Child.cancelChild'led it;-  terminal; also the decode fallback for an unrecognized stored value (the same-  defensive choice "Keiro.Timer.Schema" makes).--The constructors are prefixed @Child@ to avoid clashing with-'Keiro.Workflow.WorkflowOutcome''s @Completed@ and the awakeable\/timer-@Cancelled@ constructors.--}+-- | A child workflow's lifecycle, as seen from its parent.+--+-- * 'Running' — spawned and not yet finished; the resume worker drives it.+-- * 'ChildCompleted' — the child reached its own 'Keiro.Workflow.WorkflowCompleted'+--   and its result was propagated to the parent journal; terminal.+-- * 'ChildCancelled' — the parent 'Keiro.Workflow.Child.cancelChild'led it;+--   terminal; also the decode fallback for an unrecognized stored value (the same+--   defensive choice "Keiro.Timer.Schema" makes).+--+-- The constructors are prefixed @Child@ to avoid clashing with+-- 'Keiro.Workflow.WorkflowOutcome''s @Completed@ and the awakeable\/timer+-- @Cancelled@ constructors. data ChildStatus-    = Running-    | ChildCompleted-    | ChildCancelled-    | ChildFailed-    deriving stock (Generic, Eq, Show)+  = Running+  | ChildCompleted+  | ChildCancelled+  | ChildFailed+  deriving stock (Generic, Eq, Show) -{- | A child link row as stored: the child's (id, name), the parent's (id,-name), the parent-journal step the parent awaits ('awaitStep' =-@child:\<childId\>:result@), the live 'status', the child's 'result' (set only-once 'ChildCompleted'), the terminal 'failureReason' (set only once-'ChildFailed'), and the timestamps.--}+-- | A child link row as stored: the child's (id, name), the parent's (id,+-- name), the parent-journal step the parent awaits ('awaitStep' =+-- @child:\<childId\>:result@), the live 'status', the child's 'result' (set only+-- once 'ChildCompleted'), the terminal 'failureReason' (set only once+-- 'ChildFailed'), and the timestamps. data ChildRow = ChildRow-    { childId :: !Text-    , childName :: !Text-    , parentId :: !Text-    , parentName :: !Text-    , awaitStep :: !Text-    , status :: !ChildStatus-    , result :: !(Maybe Value)-    , failureReason :: !(Maybe Text)-    , createdAt :: !UTCTime-    , updatedAt :: !UTCTime-    , completedAt :: !(Maybe UTCTime)-    }-    deriving stock (Generic, Eq, Show)+  { childId :: !Text,+    childName :: !Text,+    parentId :: !Text,+    parentName :: !Text,+    awaitStep :: !Text,+    status :: !ChildStatus,+    result :: !(Maybe Value),+    failureReason :: !(Maybe Text),+    createdAt :: !UTCTime,+    updatedAt :: !UTCTime,+    completedAt :: !(Maybe UTCTime)+  }+  deriving stock (Generic, Eq, Show) -{- | Insert a @running@ child link row inside the caller's transaction, given-the child's @(id, name)@, the parent's @(id, name)@, and the parent-journal-step the parent awaits (@await_step@). Idempotent by-@ON CONFLICT (child_id, child_name) DO NOTHING@ — exactly what EP-38's "arm-must be idempotent" contract needs, since the spawn step and every resume's arm-re-run it. @status@, @result@, and the timestamps take their table defaults, so-no clock read is needed at the spawn site (mirrors-'Keiro.Workflow.Awakeable.Schema.registerAwakeableTx').--}+-- | Insert a @running@ child link row inside the caller's transaction, given+-- the child's @(id, name)@, the parent's @(id, name)@, and the parent-journal+-- step the parent awaits (@await_step@). Idempotent by+-- @ON CONFLICT (child_id, child_name) DO NOTHING@ — exactly what EP-38's "arm+-- must be idempotent" contract needs, since the spawn step and every resume's arm+-- re-run it. @status@, @result@, and the timestamps take their table defaults, so+-- no clock read is needed at the spawn site (mirrors+-- 'Keiro.Workflow.Awakeable.Schema.registerAwakeableTx'). registerChildTx :: Text -> Text -> Text -> Text -> Text -> Tx.Transaction () registerChildTx cid cname pid pname awaitStep =-    Tx.statement (cid, cname, pid, pname, awaitStep) registerChildStmt+  Tx.statement (cid, cname, pid, pname, awaitStep) registerChildStmt -{- | Transition a @running@ child to @completed@, storing @result@ and the-completion time, inside the caller's transaction. The @status = 'running'@-guard makes a double-complete a no-op; returns 'True' only when this call-performed the transition.--}+-- | Transition a @running@ child to @completed@, storing @result@ and the+-- completion time, inside the caller's transaction. The @status = 'running'@+-- guard makes a double-complete a no-op; returns 'True' only when this call+-- performed the transition. markChildResultTx :: Text -> Text -> Value -> UTCTime -> Tx.Transaction Bool markChildResultTx cid cname result now =-    Tx.statement (cid, cname, result, now) markChildResultStmt+  Tx.statement (cid, cname, result, now) markChildResultStmt -{- | Transition a @running@ child to @cancelled@ inside the caller's-transaction. Only @running@ rows match, so an already-completed (or-already-cancelled) child is left untouched and the call returns 'False'.--}+-- | Transition a @running@ child to @cancelled@ inside the caller's+-- transaction. Only @running@ rows match, so an already-completed (or+-- already-cancelled) child is left untouched and the call returns 'False'. markChildCancelledTx :: Text -> Text -> Tx.Transaction Bool markChildCancelledTx cid cname =-    Tx.statement (cid, cname) markChildCancelledStmt+  Tx.statement (cid, cname) markChildCancelledStmt -{- | Transition a @running@ child to @failed@, preserving the terminal reason.-The guarded transition and the parent's failure journal append are performed-in one caller-owned transaction by the resume worker.--}+-- | Transition a @running@ child to @failed@, preserving the terminal reason.+-- The guarded transition and the parent's failure journal append are performed+-- in one caller-owned transaction by the resume worker. markChildFailedTx :: Text -> Text -> Text -> Tx.Transaction Bool markChildFailedTx cid cname reason =-    Tx.statement (cid, cname, reason) markChildFailedStmt+  Tx.statement (cid, cname, reason) markChildFailedStmt -{- | Revive a @failed@ child link so the resume worker can drive the child-again. Clears terminal result metadata; the parent journal's already-delivered-failure sentinel remains immutable history.--}+-- | Revive a @failed@ child link so the resume worker can drive the child+-- again. Clears terminal result metadata; the parent journal's already-delivered+-- failure sentinel remains immutable history. reviveFailedChildTx :: Text -> Text -> Tx.Transaction Bool reviveFailedChildTx cid cname =-    Tx.statement (cid, cname) reviveFailedChildStmt+  Tx.statement (cid, cname) reviveFailedChildStmt  -- | Read a child link row by @(child_id, child_name)@. 'Nothing' if absent. lookupChild :: (Store :> es) => Text -> Text -> Eff es (Maybe ChildRow) lookupChild cid cname =-    runTransaction (Tx.statement (cid, cname) lookupChildStmt)+  runTransaction (Tx.statement (cid, cname) lookupChildStmt)  -- | Read every child link of a parent @(parent_id, parent_name)@. lookupChildrenOfParent :: (Store :> es) => Text -> Text -> Eff es [ChildRow] lookupChildrenOfParent pid pname =-    runTransaction (Tx.statement (pid, pname) lookupChildrenOfParentStmt)+  runTransaction (Tx.statement (pid, pname) lookupChildrenOfParentStmt)  -- | The 'ChildStatus' of a child by @(child_id, child_name)@, if it exists. childStatus :: (Store :> es) => Text -> Text -> Eff es (Maybe ChildStatus) childStatus cid cname = fmap (^. #status) <$> lookupChild cid cname -{- | Count children currently @running@. Read-only. EP-44 may back a-@keiro.workflow.children.active@ gauge with this.--}+-- | Count children currently @running@. Read-only. EP-44 may back a+-- @keiro.workflow.children.active@ gauge with this. countActiveChildren :: (Store :> es) => Eff es Int countActiveChildren =-    runTransaction (Tx.statement () countActiveChildrenStmt)+  runTransaction (Tx.statement () countActiveChildrenStmt) -{- | The @(child_id, child_name)@ of every @running@ child. The resume worker-unions this with 'Keiro.Workflow.findUnfinishedWorkflowIds' so a freshly-spawned child that has no @keiro_workflow_steps@ rows yet is still discovered-and driven. The tuple order matches 'findUnfinishedWorkflowIds' — @(id, name)@.--}+-- | The @(child_id, child_name)@ of every @running@ child. The resume worker+-- unions this with 'Keiro.Workflow.findUnfinishedWorkflowIds' so a freshly+-- spawned child that has no @keiro_workflow_steps@ rows yet is still discovered+-- and driven. The tuple order matches 'findUnfinishedWorkflowIds' — @(id, name)@. findRunningChildIds :: (Store :> es) => Eff es [(Text, Text)] findRunningChildIds =-    runTransaction (Tx.statement () findRunningChildIdsStmt)+  runTransaction (Tx.statement () findRunningChildIdsStmt)  registerChildStmt :: Statement (Text, Text, Text, Text, Text) () registerChildStmt =-    preparable-        """-        INSERT INTO keiro.keiro_workflow_children-          (child_id, child_name, parent_id, parent_name, await_step, status)-        VALUES ($1, $2, $3, $4, $5, 'running')-        ON CONFLICT (child_id, child_name) DO NOTHING-        """-        ( contrazip5-            (E.param (E.nonNullable E.text))-            (E.param (E.nonNullable E.text))-            (E.param (E.nonNullable E.text))-            (E.param (E.nonNullable E.text))-            (E.param (E.nonNullable E.text))-        )-        D.noResult+  preparable+    """+    INSERT INTO keiro.keiro_workflow_children+      (child_id, child_name, parent_id, parent_name, await_step, status)+    VALUES ($1, $2, $3, $4, $5, 'running')+    ON CONFLICT (child_id, child_name) DO NOTHING+    """+    ( contrazip5+        (E.param (E.nonNullable E.text))+        (E.param (E.nonNullable E.text))+        (E.param (E.nonNullable E.text))+        (E.param (E.nonNullable E.text))+        (E.param (E.nonNullable E.text))+    )+    D.noResult  markChildResultStmt :: Statement (Text, Text, Value, UTCTime) Bool markChildResultStmt =-    preparable-        """-        UPDATE keiro.keiro_workflow_children-        SET status = 'completed',-            result = $3,-            completed_at = $4,-            updated_at = now()-        WHERE child_id = $1-          AND child_name = $2-          AND status = 'running'-        """-        ( contrazip4-            (E.param (E.nonNullable E.text))-            (E.param (E.nonNullable E.text))-            (E.param (E.nonNullable E.jsonb))-            (E.param (E.nonNullable E.timestamptz))-        )-        ((> 0) <$> D.rowsAffected)+  preparable+    """+    UPDATE keiro.keiro_workflow_children+    SET status = 'completed',+        result = $3,+        completed_at = $4,+        updated_at = now()+    WHERE child_id = $1+      AND child_name = $2+      AND status = 'running'+    """+    ( contrazip4+        (E.param (E.nonNullable E.text))+        (E.param (E.nonNullable E.text))+        (E.param (E.nonNullable E.jsonb))+        (E.param (E.nonNullable E.timestamptz))+    )+    ((> 0) <$> D.rowsAffected)  markChildCancelledStmt :: Statement (Text, Text) Bool markChildCancelledStmt =-    preparable-        """-        UPDATE keiro.keiro_workflow_children-        SET status = 'cancelled',-            updated_at = now()-        WHERE child_id = $1-          AND child_name = $2-          AND status = 'running'-        """-        ( contrazip2-            (E.param (E.nonNullable E.text))-            (E.param (E.nonNullable E.text))-        )-        ((> 0) <$> D.rowsAffected)+  preparable+    """+    UPDATE keiro.keiro_workflow_children+    SET status = 'cancelled',+        updated_at = now()+    WHERE child_id = $1+      AND child_name = $2+      AND status = 'running'+    """+    ( contrazip2+        (E.param (E.nonNullable E.text))+        (E.param (E.nonNullable E.text))+    )+    ((> 0) <$> D.rowsAffected)  markChildFailedStmt :: Statement (Text, Text, Text) Bool markChildFailedStmt =-    preparable-        """-        UPDATE keiro.keiro_workflow_children-        SET status = 'failed',-            failure_reason = $3,-            updated_at = now()-        WHERE child_id = $1-          AND child_name = $2-          AND status = 'running'-        """-        ( contrazip3-            (E.param (E.nonNullable E.text))-            (E.param (E.nonNullable E.text))-            (E.param (E.nonNullable E.text))-        )-        ((> 0) <$> D.rowsAffected)+  preparable+    """+    UPDATE keiro.keiro_workflow_children+    SET status = 'failed',+        failure_reason = $3,+        updated_at = now()+    WHERE child_id = $1+      AND child_name = $2+      AND status = 'running'+    """+    ( contrazip3+        (E.param (E.nonNullable E.text))+        (E.param (E.nonNullable E.text))+        (E.param (E.nonNullable E.text))+    )+    ((> 0) <$> D.rowsAffected)  reviveFailedChildStmt :: Statement (Text, Text) Bool reviveFailedChildStmt =-    preparable-        """-        UPDATE keiro.keiro_workflow_children-        SET status = 'running',-            result = NULL,-            failure_reason = NULL,-            completed_at = NULL,-            updated_at = now()-        WHERE child_id = $1-          AND child_name = $2-          AND status = 'failed'-        """-        ( contrazip2-            (E.param (E.nonNullable E.text))-            (E.param (E.nonNullable E.text))-        )-        ((> 0) <$> D.rowsAffected)+  preparable+    """+    UPDATE keiro.keiro_workflow_children+    SET status = 'running',+        result = NULL,+        failure_reason = NULL,+        completed_at = NULL,+        updated_at = now()+    WHERE child_id = $1+      AND child_name = $2+      AND status = 'failed'+    """+    ( contrazip2+        (E.param (E.nonNullable E.text))+        (E.param (E.nonNullable E.text))+    )+    ((> 0) <$> D.rowsAffected)  lookupChildStmt :: Statement (Text, Text) (Maybe ChildRow) lookupChildStmt =-    preparable-        """-        SELECT child_id, child_name, parent_id, parent_name, await_step,-          status, result, failure_reason, created_at, updated_at, completed_at-        FROM keiro.keiro_workflow_children-        WHERE child_id = $1-          AND child_name = $2-        """-        ( contrazip2-            (E.param (E.nonNullable E.text))-            (E.param (E.nonNullable E.text))-        )-        (D.rowMaybe childRowDecoder)+  preparable+    """+    SELECT child_id, child_name, parent_id, parent_name, await_step,+      status, result, failure_reason, created_at, updated_at, completed_at+    FROM keiro.keiro_workflow_children+    WHERE child_id = $1+      AND child_name = $2+    """+    ( contrazip2+        (E.param (E.nonNullable E.text))+        (E.param (E.nonNullable E.text))+    )+    (D.rowMaybe childRowDecoder)  lookupChildrenOfParentStmt :: Statement (Text, Text) [ChildRow] lookupChildrenOfParentStmt =-    preparable-        """-        SELECT child_id, child_name, parent_id, parent_name, await_step,-          status, result, failure_reason, created_at, updated_at, completed_at-        FROM keiro.keiro_workflow_children-        WHERE parent_id = $1-          AND parent_name = $2-        ORDER BY created_at, child_id-        """-        ( contrazip2-            (E.param (E.nonNullable E.text))-            (E.param (E.nonNullable E.text))-        )-        (D.rowList childRowDecoder)+  preparable+    """+    SELECT child_id, child_name, parent_id, parent_name, await_step,+      status, result, failure_reason, created_at, updated_at, completed_at+    FROM keiro.keiro_workflow_children+    WHERE parent_id = $1+      AND parent_name = $2+    ORDER BY created_at, child_id+    """+    ( contrazip2+        (E.param (E.nonNullable E.text))+        (E.param (E.nonNullable E.text))+    )+    (D.rowList childRowDecoder)  countActiveChildrenStmt :: Statement () Int countActiveChildrenStmt =-    preparable-        """-        SELECT count(*)-        FROM keiro.keiro_workflow_children-        WHERE status = 'running'-        """-        E.noParams-        (D.singleRow (fromIntegral <$> D.column (D.nonNullable D.int8)))+  preparable+    """+    SELECT count(*)+    FROM keiro.keiro_workflow_children+    WHERE status = 'running'+    """+    E.noParams+    (D.singleRow (fromIntegral <$> D.column (D.nonNullable D.int8)))  findRunningChildIdsStmt :: Statement () [(Text, Text)] findRunningChildIdsStmt =-    preparable-        """-        SELECT child_id, child_name-        FROM keiro.keiro_workflow_children-        WHERE status = 'running'-        """-        E.noParams-        (D.rowList ((,) <$> D.column (D.nonNullable D.text) <*> D.column (D.nonNullable D.text)))+  preparable+    """+    SELECT child_id, child_name+    FROM keiro.keiro_workflow_children+    WHERE status = 'running'+    """+    E.noParams+    (D.rowList ((,) <$> D.column (D.nonNullable D.text) <*> D.column (D.nonNullable D.text)))  childRowDecoder :: D.Row ChildRow childRowDecoder =-    ChildRow-        <$> D.column (D.nonNullable D.text)-        <*> D.column (D.nonNullable D.text)-        <*> D.column (D.nonNullable D.text)-        <*> D.column (D.nonNullable D.text)-        <*> D.column (D.nonNullable D.text)-        <*> (statusFromText <$> D.column (D.nonNullable D.text))-        <*> D.column (D.nullable D.jsonb)-        <*> D.column (D.nullable D.text)-        <*> D.column (D.nonNullable D.timestamptz)-        <*> D.column (D.nonNullable D.timestamptz)-        <*> D.column (D.nullable D.timestamptz)+  ChildRow+    <$> D.column (D.nonNullable D.text)+    <*> D.column (D.nonNullable D.text)+    <*> D.column (D.nonNullable D.text)+    <*> D.column (D.nonNullable D.text)+    <*> D.column (D.nonNullable D.text)+    <*> (statusFromText <$> D.column (D.nonNullable D.text))+    <*> D.column (D.nullable D.jsonb)+    <*> D.column (D.nullable D.text)+    <*> D.column (D.nonNullable D.timestamptz)+    <*> D.column (D.nonNullable D.timestamptz)+    <*> D.column (D.nullable D.timestamptz)  statusToText :: ChildStatus -> Text statusToText = \case-    Running -> "running"-    ChildCompleted -> "completed"-    ChildCancelled -> "cancelled"-    ChildFailed -> "failed"+  Running -> "running"+  ChildCompleted -> "completed"+  ChildCancelled -> "cancelled"+  ChildFailed -> "failed"  statusFromText :: Text -> ChildStatus statusFromText = \case-    "running" -> Running-    "completed" -> ChildCompleted-    "cancelled" -> ChildCancelled-    "failed" -> ChildFailed-    _ -> ChildCancelled+  "running" -> Running+  "completed" -> ChildCompleted+  "cancelled" -> ChildCancelled+  "failed" -> ChildFailed+  _ -> ChildCancelled
src/Keiro/Workflow/Gc.hs view
@@ -1,19 +1,18 @@-{- | Optional garbage collection for terminal workflow instances.--The hot-path schema modules keep lifecycle writes and lookup statements. This-module owns only cleanup statements used by an operator-scheduled GC pass.-Eligibility is based on the derived @keiro_workflows@ row: terminal instances-older than the retention cutoff are deleted, except completed children whose-parent is still non-terminal and may still attach to their result. Cleanup-removes workflow-sleep timers in every lifecycle state so no scheduled timer-can later recreate a collected workflow.--}-module Keiro.Workflow.Gc (-    WorkflowGcPolicy (..),+-- | Optional garbage collection for terminal workflow instances.+--+-- The hot-path schema modules keep lifecycle writes and lookup statements. This+-- module owns only cleanup statements used by an operator-scheduled GC pass.+-- Eligibility is based on the derived @keiro_workflows@ row: terminal instances+-- older than the retention cutoff are deleted, except completed children whose+-- parent is still non-terminal and may still attach to their result. Cleanup+-- removes workflow-sleep timers in every lifecycle state so no scheduled timer+-- can later recreate a collected workflow.+module Keiro.Workflow.Gc+  ( WorkflowGcPolicy (..),     WorkflowGcSummary (..),     gcWorkflowsOnce,     runWorkflowGcWorker,-)+  ) where  import Contravariant.Extras (contrazip2, contrazip3, contrazip4)@@ -36,161 +35,161 @@ import "hasql-transaction" Hasql.Transaction qualified as Tx  data WorkflowGcPolicy = WorkflowGcPolicy-    { retention :: !NominalDiffTime-    , batchSize :: !Int-    }-    deriving stock (Generic, Eq, Show)+  { retention :: !NominalDiffTime,+    batchSize :: !Int+  }+  deriving stock (Generic, Eq, Show)  data WorkflowGcSummary = WorkflowGcSummary-    { scanned :: !Int-    , deleted :: !Int-    }-    deriving stock (Generic, Eq, Show)+  { scanned :: !Int,+    deleted :: !Int+  }+  deriving stock (Generic, Eq, Show)  gcWorkflowsOnce :: (Store :> es) => UTCTime -> WorkflowGcPolicy -> Eff es WorkflowGcSummary gcWorkflowsOnce now policy = do-    let cutoff = addUTCTime (negate (policy ^. #retention)) now-        limit = max 0 (policy ^. #batchSize)-    eligible <- runTransaction (Tx.statement (cutoff, fromIntegral limit :: Int32) eligibleWorkflowsStmt)-    deletedCount <- length <$> traverse deleteWorkflow eligible-    pure WorkflowGcSummary{scanned = length eligible, deleted = deletedCount}+  let cutoff = addUTCTime (negate (policy ^. #retention)) now+      limit = max 0 (policy ^. #batchSize)+  eligible <- runTransaction (Tx.statement (cutoff, fromIntegral limit :: Int32) eligibleWorkflowsStmt)+  deletedCount <- length <$> traverse deleteWorkflow eligible+  pure WorkflowGcSummary {scanned = length eligible, deleted = deletedCount}  runWorkflowGcWorker :: (IOE :> es, Store :> es) => WorkflowGcPolicy -> Int -> Eff es () runWorkflowGcWorker policy pollMicros =-    forever $ do-        now <- liftIO getCurrentTime-        void (gcWorkflowsOnce now policy)-        liftIO (threadDelay pollMicros)+  forever $ do+    now <- liftIO getCurrentTime+    void (gcWorkflowsOnce now policy)+    liftIO (threadDelay pollMicros)  deleteWorkflow :: (Store :> es) => (Text, Text) -> Eff es () deleteWorkflow (widText, nameText) = do-    let name = WorkflowName nameText-        wid = WorkflowId widText-    gen <- currentGeneration name wid-    for_ [0 .. gen] $ \generation -> do-        let streamName = workflowGenerationStreamName name wid generation-        mStreamId <- lookupStreamId streamName-        for_ mStreamId $ \(StreamId sid) ->-            runTransaction (Tx.statement sid deleteSnapshotStmt)-        void (hardDeleteStream streamName)-    runTransaction $ do-        Tx.statement (widText, nameText) deleteStepsStmt-        Tx.statement (nameText, widText) deleteAwakeablesStmt-        Tx.statement (widText, nameText, widText, nameText) deleteChildrenStmt-        -- Eligibility is already terminal, so remove every owned sleep timer:-        -- a scheduled survivor could otherwise recreate this workflow later.-        -- Keep this literal in sync with Keiro.Workflow.Sleep.workflowSleepKind.-        Tx.statement (widText, nameText, workflowSleepKindLiteral) deleteSleepTimersStmt-        Tx.statement (widText, nameText) deleteWorkflowStmt+  let name = WorkflowName nameText+      wid = WorkflowId widText+  gen <- currentGeneration name wid+  for_ [0 .. gen] $ \generation -> do+    let streamName = workflowGenerationStreamName name wid generation+    mStreamId <- lookupStreamId streamName+    for_ mStreamId $ \(StreamId sid) ->+      runTransaction (Tx.statement sid deleteSnapshotStmt)+    void (hardDeleteStream streamName)+  runTransaction $ do+    Tx.statement (widText, nameText) deleteStepsStmt+    Tx.statement (nameText, widText) deleteAwakeablesStmt+    Tx.statement (widText, nameText, widText, nameText) deleteChildrenStmt+    -- Eligibility is already terminal, so remove every owned sleep timer:+    -- a scheduled survivor could otherwise recreate this workflow later.+    -- Keep this literal in sync with Keiro.Workflow.Sleep.workflowSleepKind.+    Tx.statement (widText, nameText, workflowSleepKindLiteral) deleteSleepTimersStmt+    Tx.statement (widText, nameText) deleteWorkflowStmt  workflowSleepKindLiteral :: Text workflowSleepKindLiteral = "keiro.workflow.sleep"  eligibleWorkflowsStmt :: Statement (UTCTime, Int32) [(Text, Text)] eligibleWorkflowsStmt =-    preparable-        """-        SELECT w.workflow_id, w.workflow_name-        FROM keiro.keiro_workflows w-        WHERE w.status IN ('completed', 'cancelled', 'failed')-          AND w.completed_at IS NOT NULL-          AND w.completed_at <= $1-          AND NOT EXISTS (-            SELECT 1-            FROM keiro.keiro_workflow_children c-            JOIN keiro.keiro_workflows p-              ON p.workflow_id = c.parent_id-             AND p.workflow_name = c.parent_name-            WHERE c.child_id = w.workflow_id-              AND c.child_name = w.workflow_name-              AND p.status NOT IN ('completed', 'cancelled', 'failed')-          )-        ORDER BY w.completed_at-        LIMIT $2-        """-        ( contrazip2-            (E.param (E.nonNullable E.timestamptz))-            (E.param (E.nonNullable E.int4))-        )-        (D.rowList ((,) <$> D.column (D.nonNullable D.text) <*> D.column (D.nonNullable D.text)))+  preparable+    """+    SELECT w.workflow_id, w.workflow_name+    FROM keiro.keiro_workflows w+    WHERE w.status IN ('completed', 'cancelled', 'failed')+      AND w.completed_at IS NOT NULL+      AND w.completed_at <= $1+      AND NOT EXISTS (+        SELECT 1+        FROM keiro.keiro_workflow_children c+        JOIN keiro.keiro_workflows p+          ON p.workflow_id = c.parent_id+         AND p.workflow_name = c.parent_name+        WHERE c.child_id = w.workflow_id+          AND c.child_name = w.workflow_name+          AND p.status NOT IN ('completed', 'cancelled', 'failed')+      )+    ORDER BY w.completed_at+    LIMIT $2+    """+    ( contrazip2+        (E.param (E.nonNullable E.timestamptz))+        (E.param (E.nonNullable E.int4))+    )+    (D.rowList ((,) <$> D.column (D.nonNullable D.text) <*> D.column (D.nonNullable D.text)))  deleteSnapshotStmt :: Statement Int64 () deleteSnapshotStmt =-    preparable-        """-        DELETE FROM keiro.keiro_snapshots-        WHERE stream_id = $1-        """-        (E.param (E.nonNullable E.int8))-        D.noResult+  preparable+    """+    DELETE FROM keiro.keiro_snapshots+    WHERE stream_id = $1+    """+    (E.param (E.nonNullable E.int8))+    D.noResult  deleteStepsStmt :: Statement (Text, Text) () deleteStepsStmt =-    preparable-        """-        DELETE FROM keiro.keiro_workflow_steps-        WHERE workflow_id = $1 AND workflow_name = $2-        """-        ( contrazip2-            (E.param (E.nonNullable E.text))-            (E.param (E.nonNullable E.text))-        )-        D.noResult+  preparable+    """+    DELETE FROM keiro.keiro_workflow_steps+    WHERE workflow_id = $1 AND workflow_name = $2+    """+    ( contrazip2+        (E.param (E.nonNullable E.text))+        (E.param (E.nonNullable E.text))+    )+    D.noResult  deleteAwakeablesStmt :: Statement (Text, Text) () deleteAwakeablesStmt =-    preparable-        """-        DELETE FROM keiro.keiro_awakeables-        WHERE owner_workflow_name = $1 AND owner_workflow_id = $2-        """-        ( contrazip2-            (E.param (E.nonNullable E.text))-            (E.param (E.nonNullable E.text))-        )-        D.noResult+  preparable+    """+    DELETE FROM keiro.keiro_awakeables+    WHERE owner_workflow_name = $1 AND owner_workflow_id = $2+    """+    ( contrazip2+        (E.param (E.nonNullable E.text))+        (E.param (E.nonNullable E.text))+    )+    D.noResult  deleteChildrenStmt :: Statement (Text, Text, Text, Text) () deleteChildrenStmt =-    preparable-        """-        DELETE FROM keiro.keiro_workflow_children-        WHERE (parent_id = $1 AND parent_name = $2)-           OR (child_id = $3 AND child_name = $4)-        """-        ( contrazip4-            (E.param (E.nonNullable E.text))-            (E.param (E.nonNullable E.text))-            (E.param (E.nonNullable E.text))-            (E.param (E.nonNullable E.text))-        )-        D.noResult+  preparable+    """+    DELETE FROM keiro.keiro_workflow_children+    WHERE (parent_id = $1 AND parent_name = $2)+       OR (child_id = $3 AND child_name = $4)+    """+    ( contrazip4+        (E.param (E.nonNullable E.text))+        (E.param (E.nonNullable E.text))+        (E.param (E.nonNullable E.text))+        (E.param (E.nonNullable E.text))+    )+    D.noResult  deleteSleepTimersStmt :: Statement (Text, Text, Text) () deleteSleepTimersStmt =-    preparable-        """-        DELETE FROM keiro.keiro_timers-        WHERE correlation_id = $1-          AND process_manager_name = $2-          AND payload->>'kind' = $3-        """-        ( contrazip3-            (E.param (E.nonNullable E.text))-            (E.param (E.nonNullable E.text))-            (E.param (E.nonNullable E.text))-        )-        D.noResult+  preparable+    """+    DELETE FROM keiro.keiro_timers+    WHERE correlation_id = $1+      AND process_manager_name = $2+      AND payload->>'kind' = $3+    """+    ( contrazip3+        (E.param (E.nonNullable E.text))+        (E.param (E.nonNullable E.text))+        (E.param (E.nonNullable E.text))+    )+    D.noResult  deleteWorkflowStmt :: Statement (Text, Text) () deleteWorkflowStmt =-    preparable-        """-        DELETE FROM keiro.keiro_workflows-        WHERE workflow_id = $1 AND workflow_name = $2-        """-        ( contrazip2-            (E.param (E.nonNullable E.text))-            (E.param (E.nonNullable E.text))-        )-        D.noResult+  preparable+    """+    DELETE FROM keiro.keiro_workflows+    WHERE workflow_id = $1 AND workflow_name = $2+    """+    ( contrazip2+        (E.param (E.nonNullable E.text))+        (E.param (E.nonNullable E.text))+    )+    D.noResult
src/Keiro/Workflow/Instance.hs view
@@ -1,12 +1,11 @@-{- | Durable workflow instance summaries.--The journal stream and @keiro_workflow_steps@ index remain the source of truth-for replay. This module maintains one @keiro_workflows@ row per logical-workflow instance so the resume worker can track lifecycle, attempts, and-leases without scanning journal history.--}-module Keiro.Workflow.Instance (-    WorkflowStatus (..),+-- | Durable workflow instance summaries.+--+-- The journal stream and @keiro_workflow_steps@ index remain the source of truth+-- for replay. This module maintains one @keiro_workflows@ row per logical+-- workflow instance so the resume worker can track lifecycle, attempts, and+-- leases without scanning journal history.+module Keiro.Workflow.Instance+  ( WorkflowStatus (..),     WorkflowInstanceRow (..),     ResurrectOutcome (..),     statusToText,@@ -22,7 +21,7 @@     resetInstanceAttempts,     reviveFailedInstanceTx,     resurrectFailedWorkflow,-)+  ) where  import Contravariant.Extras (contrazip2, contrazip3, contrazip4, contrazip5)@@ -41,357 +40,355 @@ import "hasql-transaction" Hasql.Transaction qualified as Tx  data WorkflowStatus-    = WfRunning-    | WfSuspended-    | WfCompleted-    | WfCancelled-    | WfFailed-    deriving stock (Generic, Eq, Show)+  = WfRunning+  | WfSuspended+  | WfCompleted+  | WfCancelled+  | WfFailed+  deriving stock (Generic, Eq, Show)  data WorkflowInstanceRow = WorkflowInstanceRow-    { workflowId :: !Text-    , workflowName :: !Text-    , generation :: !Int32-    , status :: !WorkflowStatus-    , attempts :: !Int32-    , lastError :: !(Maybe Text)-    , nextAttemptAt :: !(Maybe UTCTime)-    , leasedBy :: !(Maybe Text)-    , leaseExpiresAt :: !(Maybe UTCTime)-    , createdAt :: !UTCTime-    , updatedAt :: !UTCTime-    , completedAt :: !(Maybe UTCTime)-    }-    deriving stock (Generic, Eq, Show)+  { workflowId :: !Text,+    workflowName :: !Text,+    generation :: !Int32,+    status :: !WorkflowStatus,+    attempts :: !Int32,+    lastError :: !(Maybe Text),+    nextAttemptAt :: !(Maybe UTCTime),+    leasedBy :: !(Maybe Text),+    leaseExpiresAt :: !(Maybe UTCTime),+    createdAt :: !UTCTime,+    updatedAt :: !UTCTime,+    completedAt :: !(Maybe UTCTime)+  }+  deriving stock (Generic, Eq, Show)  data ResurrectOutcome-    = WorkflowResurrected-    | WorkflowNotFailed-    | WorkflowNotFound-    deriving stock (Generic, Eq, Show)+  = WorkflowResurrected+  | WorkflowNotFailed+  | WorkflowNotFound+  deriving stock (Generic, Eq, Show)  upsertInstanceTx :: Text -> Text -> Int32 -> WorkflowStatus -> Maybe Text -> Tx.Transaction () upsertInstanceTx wid name gen status mLastError =-    Tx.statement (wid, name, gen, statusToText status, mLastError) upsertInstanceStmt+  Tx.statement (wid, name, gen, statusToText status, mLastError) upsertInstanceStmt  markInstanceSuspended :: (Store :> es) => WorkflowName -> WorkflowId -> Eff es () markInstanceSuspended name@(WorkflowName nameText) wid@(WorkflowId widText) = do-    gen <- currentGeneration name wid-    runTransaction $-        upsertInstanceTx widText nameText (fromIntegral gen) WfSuspended Nothing+  gen <- currentGeneration name wid+  runTransaction $+    upsertInstanceTx widText nameText (fromIntegral gen) WfSuspended Nothing  lookupInstance :: (Store :> es) => WorkflowName -> WorkflowId -> Eff es (Maybe WorkflowInstanceRow) lookupInstance (WorkflowName name) (WorkflowId wid) =-    runTransaction (Tx.statement (wid, name) lookupInstanceStmt)+  runTransaction (Tx.statement (wid, name) lookupInstanceStmt)  claimInstance :: (IOE :> es, Store :> es) => Text -> NominalDiffTime -> WorkflowName -> WorkflowId -> Eff es Bool claimInstance owner ttl name@(WorkflowName nameText) wid@(WorkflowId widText) = do-    now <- liftIO getCurrentTime-    gen <- currentGeneration name wid-    runTransaction $ do-        Tx.statement (widText, nameText, fromIntegral gen :: Int32) ensureInstanceStmt-        fromMaybe False-            <$> Tx.statement-                (widText, nameText, owner, now, addUTCTime ttl now)-                claimInstanceStmt--{- | Extend an instance lease only when @owner@ still holds it.+  now <- liftIO getCurrentTime+  gen <- currentGeneration name wid+  runTransaction $ do+    Tx.statement (widText, nameText, fromIntegral gen :: Int32) ensureInstanceStmt+    fromMaybe False+      <$> Tx.statement+        (widText, nameText, owner, now, addUTCTime ttl now)+        claimInstanceStmt -The caller supplies one clock reading so @updated_at@ and the new expiry share-the same boundary. Returns 'False' after ownership is lost or the row vanishes.--}+-- | Extend an instance lease only when @owner@ still holds it.+--+-- The caller supplies one clock reading so @updated_at@ and the new expiry share+-- the same boundary. Returns 'False' after ownership is lost or the row vanishes. renewInstanceLeaseTx ::-    Text ->-    NominalDiffTime ->-    UTCTime ->-    Text ->-    Text ->-    Tx.Transaction Bool+  Text ->+  NominalDiffTime ->+  UTCTime ->+  Text ->+  Text ->+  Tx.Transaction Bool renewInstanceLeaseTx owner ttl now wid name =-    Tx.statement-        (wid, name, owner, now, addUTCTime ttl now)-        renewInstanceLeaseStmt+  Tx.statement+    (wid, name, owner, now, addUTCTime ttl now)+    renewInstanceLeaseStmt  -- | Effect-level wrapper around 'renewInstanceLeaseTx' using the current time. renewInstanceLease ::-    (IOE :> es, Store :> es) =>-    Text ->-    NominalDiffTime ->-    WorkflowName ->-    WorkflowId ->-    Eff es Bool+  (IOE :> es, Store :> es) =>+  Text ->+  NominalDiffTime ->+  WorkflowName ->+  WorkflowId ->+  Eff es Bool renewInstanceLease owner ttl (WorkflowName name) (WorkflowId wid) = do-    now <- liftIO getCurrentTime-    runTransaction (renewInstanceLeaseTx owner ttl now wid name)+  now <- liftIO getCurrentTime+  runTransaction (renewInstanceLeaseTx owner ttl now wid name)  releaseInstance :: (Store :> es) => Text -> Bool -> WorkflowName -> WorkflowId -> Eff es () releaseInstance owner progressed (WorkflowName name) (WorkflowId wid) =-    runTransaction $-        Tx.statement (wid, name, owner, progressed) releaseInstanceStmt+  runTransaction $+    Tx.statement (wid, name, owner, progressed) releaseInstanceStmt  recordCrashTx :: Text -> Text -> Text -> Tx.Transaction Int32 recordCrashTx wid name err =-    Tx.statement (wid, name, err) recordCrashStmt+  Tx.statement (wid, name, err) recordCrashStmt  resetInstanceAttempts :: (Store :> es) => WorkflowName -> WorkflowId -> Eff es () resetInstanceAttempts (WorkflowName name) (WorkflowId wid) =-    runTransaction (Tx.statement (wid, name) resetInstanceAttemptsStmt)+  runTransaction (Tx.statement (wid, name) resetInstanceAttemptsStmt)  reviveFailedInstanceTx :: Text -> Text -> Tx.Transaction Bool reviveFailedInstanceTx wid name =-    Tx.statement (wid, name) reviveFailedInstanceStmt--{- | Return a terminally failed workflow to the runnable pool.+  Tx.statement (wid, name) reviveFailedInstanceStmt -The operation removes only the current generation's derived failed-marker index-row; the append-only 'Keiro.Workflow.WorkflowFailed' journal event remains as-history. A failed child link is revived in the same transaction. Parent failure-sentinels already delivered to another journal are not retracted.--}+-- | Return a terminally failed workflow to the runnable pool.+--+-- The operation removes only the current generation's derived failed-marker index+-- row; the append-only 'Keiro.Workflow.WorkflowFailed' journal event remains as+-- history. A failed child link is revived in the same transaction. Parent failure+-- sentinels already delivered to another journal are not retracted. resurrectFailedWorkflow ::-    (Store :> es) =>-    WorkflowName ->-    WorkflowId ->-    Eff es ResurrectOutcome+  (Store :> es) =>+  WorkflowName ->+  WorkflowId ->+  Eff es ResurrectOutcome resurrectFailedWorkflow name@(WorkflowName nameText) wid@(WorkflowId widText) =-    lookupInstance name wid >>= \case-        Nothing -> pure WorkflowNotFound-        Just row-            | row ^. #status /= WfFailed -> pure WorkflowNotFailed-            | otherwise -> do-                gen <- currentGeneration name wid-                revived <--                    runTransaction $ do-                        instanceRevived <- reviveFailedInstanceTx widText nameText-                        when instanceRevived $ do-                            deleteStepRowTx widText nameText gen failedStepName-                            void (reviveFailedChildTx widText nameText)-                        pure instanceRevived-                pure $-                    if revived-                        then WorkflowResurrected-                        else WorkflowNotFailed+  lookupInstance name wid >>= \case+    Nothing -> pure WorkflowNotFound+    Just row+      | row ^. #status /= WfFailed -> pure WorkflowNotFailed+      | otherwise -> do+          gen <- currentGeneration name wid+          revived <-+            runTransaction $ do+              instanceRevived <- reviveFailedInstanceTx widText nameText+              when instanceRevived $ do+                deleteStepRowTx widText nameText gen failedStepName+                void (reviveFailedChildTx widText nameText)+              pure instanceRevived+          pure $+            if revived+              then WorkflowResurrected+              else WorkflowNotFailed  statusToText :: WorkflowStatus -> Text statusToText = \case-    WfRunning -> "running"-    WfSuspended -> "suspended"-    WfCompleted -> "completed"-    WfCancelled -> "cancelled"-    WfFailed -> "failed"+  WfRunning -> "running"+  WfSuspended -> "suspended"+  WfCompleted -> "completed"+  WfCancelled -> "cancelled"+  WfFailed -> "failed"  statusFromText :: Text -> WorkflowStatus statusFromText = \case-    "running" -> WfRunning-    "suspended" -> WfSuspended-    "completed" -> WfCompleted-    "cancelled" -> WfCancelled-    "failed" -> WfFailed-    _ -> WfFailed+  "running" -> WfRunning+  "suspended" -> WfSuspended+  "completed" -> WfCompleted+  "cancelled" -> WfCancelled+  "failed" -> WfFailed+  _ -> WfFailed  upsertInstanceStmt :: Statement (Text, Text, Int32, Text, Maybe Text) () upsertInstanceStmt =-    preparable-        """-        INSERT INTO keiro.keiro_workflows-          (workflow_id, workflow_name, generation, status, last_error, completed_at)-        VALUES ($1, $2, $3, $4, $5,-                CASE WHEN $4 IN ('completed', 'cancelled', 'failed') THEN now() ELSE NULL END)-        ON CONFLICT (workflow_id, workflow_name) DO UPDATE-        SET generation = GREATEST(keiro_workflows.generation, EXCLUDED.generation),-            status = EXCLUDED.status,-            last_error = EXCLUDED.last_error,-            updated_at = now(),-            completed_at = CASE-              WHEN EXCLUDED.status IN ('completed', 'cancelled', 'failed')-                THEN COALESCE(keiro_workflows.completed_at, now())-              ELSE keiro_workflows.completed_at-            END-        WHERE keiro_workflows.status NOT IN ('completed', 'cancelled', 'failed')-        """-        ( contrazip5-            (E.param (E.nonNullable E.text))-            (E.param (E.nonNullable E.text))-            (E.param (E.nonNullable E.int4))-            (E.param (E.nonNullable E.text))-            (E.param (E.nullable E.text))-        )-        D.noResult+  preparable+    """+    INSERT INTO keiro.keiro_workflows+      (workflow_id, workflow_name, generation, status, last_error, completed_at)+    VALUES ($1, $2, $3, $4, $5,+            CASE WHEN $4 IN ('completed', 'cancelled', 'failed') THEN now() ELSE NULL END)+    ON CONFLICT (workflow_id, workflow_name) DO UPDATE+    SET generation = GREATEST(keiro_workflows.generation, EXCLUDED.generation),+        status = EXCLUDED.status,+        last_error = EXCLUDED.last_error,+        updated_at = now(),+        completed_at = CASE+          WHEN EXCLUDED.status IN ('completed', 'cancelled', 'failed')+            THEN COALESCE(keiro_workflows.completed_at, now())+          ELSE keiro_workflows.completed_at+        END+    WHERE keiro_workflows.status NOT IN ('completed', 'cancelled', 'failed')+    """+    ( contrazip5+        (E.param (E.nonNullable E.text))+        (E.param (E.nonNullable E.text))+        (E.param (E.nonNullable E.int4))+        (E.param (E.nonNullable E.text))+        (E.param (E.nullable E.text))+    )+    D.noResult  lookupInstanceStmt :: Statement (Text, Text) (Maybe WorkflowInstanceRow) lookupInstanceStmt =-    preparable-        """-        SELECT workflow_id, workflow_name, generation, status, attempts,-               last_error, next_attempt_at, leased_by, lease_expires_at,-               created_at, updated_at, completed_at-        FROM keiro.keiro_workflows-        WHERE workflow_id = $1 AND workflow_name = $2-        """-        ( contrazip2-            (E.param (E.nonNullable E.text))-            (E.param (E.nonNullable E.text))-        )-        (D.rowMaybe instanceRowDecoder)+  preparable+    """+    SELECT workflow_id, workflow_name, generation, status, attempts,+           last_error, next_attempt_at, leased_by, lease_expires_at,+           created_at, updated_at, completed_at+    FROM keiro.keiro_workflows+    WHERE workflow_id = $1 AND workflow_name = $2+    """+    ( contrazip2+        (E.param (E.nonNullable E.text))+        (E.param (E.nonNullable E.text))+    )+    (D.rowMaybe instanceRowDecoder)  ensureInstanceStmt :: Statement (Text, Text, Int32) () ensureInstanceStmt =-    preparable-        """-        INSERT INTO keiro.keiro_workflows-          (workflow_id, workflow_name, generation, status)-        VALUES ($1, $2, $3, 'running')-        ON CONFLICT (workflow_id, workflow_name) DO NOTHING-        """-        ( contrazip3-            (E.param (E.nonNullable E.text))-            (E.param (E.nonNullable E.text))-            (E.param (E.nonNullable E.int4))-        )-        D.noResult+  preparable+    """+    INSERT INTO keiro.keiro_workflows+      (workflow_id, workflow_name, generation, status)+    VALUES ($1, $2, $3, 'running')+    ON CONFLICT (workflow_id, workflow_name) DO NOTHING+    """+    ( contrazip3+        (E.param (E.nonNullable E.text))+        (E.param (E.nonNullable E.text))+        (E.param (E.nonNullable E.int4))+    )+    D.noResult  claimInstanceStmt :: Statement (Text, Text, Text, UTCTime, UTCTime) (Maybe Bool) claimInstanceStmt =-    preparable-        """-        UPDATE keiro.keiro_workflows-        SET leased_by = $3,-            lease_expires_at = $5,-            updated_at = $4-        WHERE workflow_id = $1-          AND workflow_name = $2-          AND status IN ('running', 'suspended')-          AND (lease_expires_at IS NULL OR lease_expires_at < $4)-          AND (next_attempt_at IS NULL OR next_attempt_at <= $4)-        RETURNING TRUE-        """-        ( contrazip5-            (E.param (E.nonNullable E.text))-            (E.param (E.nonNullable E.text))-            (E.param (E.nonNullable E.text))-            (E.param (E.nonNullable E.timestamptz))-            (E.param (E.nonNullable E.timestamptz))-        )-        (D.rowMaybe (D.column (D.nonNullable D.bool)))+  preparable+    """+    UPDATE keiro.keiro_workflows+    SET leased_by = $3,+        lease_expires_at = $5,+        updated_at = $4+    WHERE workflow_id = $1+      AND workflow_name = $2+      AND status IN ('running', 'suspended')+      AND (lease_expires_at IS NULL OR lease_expires_at < $4)+      AND (next_attempt_at IS NULL OR next_attempt_at <= $4)+    RETURNING TRUE+    """+    ( contrazip5+        (E.param (E.nonNullable E.text))+        (E.param (E.nonNullable E.text))+        (E.param (E.nonNullable E.text))+        (E.param (E.nonNullable E.timestamptz))+        (E.param (E.nonNullable E.timestamptz))+    )+    (D.rowMaybe (D.column (D.nonNullable D.bool)))  renewInstanceLeaseStmt :: Statement (Text, Text, Text, UTCTime, UTCTime) Bool renewInstanceLeaseStmt =-    preparable-        """-        UPDATE keiro.keiro_workflows-        SET lease_expires_at = $5,-            updated_at = $4-        WHERE workflow_id = $1-          AND workflow_name = $2-          AND leased_by = $3-        """-        ( contrazip5-            (E.param (E.nonNullable E.text))-            (E.param (E.nonNullable E.text))-            (E.param (E.nonNullable E.text))-            (E.param (E.nonNullable E.timestamptz))-            (E.param (E.nonNullable E.timestamptz))-        )-        ((> 0) <$> D.rowsAffected)+  preparable+    """+    UPDATE keiro.keiro_workflows+    SET lease_expires_at = $5,+        updated_at = $4+    WHERE workflow_id = $1+      AND workflow_name = $2+      AND leased_by = $3+    """+    ( contrazip5+        (E.param (E.nonNullable E.text))+        (E.param (E.nonNullable E.text))+        (E.param (E.nonNullable E.text))+        (E.param (E.nonNullable E.timestamptz))+        (E.param (E.nonNullable E.timestamptz))+    )+    ((> 0) <$> D.rowsAffected)  releaseInstanceStmt :: Statement (Text, Text, Text, Bool) () releaseInstanceStmt =-    preparable-        """-        UPDATE keiro.keiro_workflows-        SET leased_by = NULL,-            lease_expires_at = NULL,-            attempts = CASE WHEN $4 THEN 0 ELSE attempts END,-            last_error = CASE WHEN $4 THEN NULL ELSE last_error END,-            next_attempt_at = CASE WHEN $4 THEN NULL ELSE next_attempt_at END,-            updated_at = now()-        WHERE workflow_id = $1-          AND workflow_name = $2-          AND leased_by = $3-        """-        ( contrazip4-            (E.param (E.nonNullable E.text))-            (E.param (E.nonNullable E.text))-            (E.param (E.nonNullable E.text))-            (E.param (E.nonNullable E.bool))-        )-        D.noResult+  preparable+    """+    UPDATE keiro.keiro_workflows+    SET leased_by = NULL,+        lease_expires_at = NULL,+        attempts = CASE WHEN $4 THEN 0 ELSE attempts END,+        last_error = CASE WHEN $4 THEN NULL ELSE last_error END,+        next_attempt_at = CASE WHEN $4 THEN NULL ELSE next_attempt_at END,+        updated_at = now()+    WHERE workflow_id = $1+      AND workflow_name = $2+      AND leased_by = $3+    """+    ( contrazip4+        (E.param (E.nonNullable E.text))+        (E.param (E.nonNullable E.text))+        (E.param (E.nonNullable E.text))+        (E.param (E.nonNullable E.bool))+    )+    D.noResult  recordCrashStmt :: Statement (Text, Text, Text) Int32 recordCrashStmt =-    preparable-        """-        UPDATE keiro.keiro_workflows-        SET attempts = attempts + 1,-            last_error = $3,-            next_attempt_at = now() + (LEAST(power(2, attempts + 1), 64) * interval '1 second'),-            updated_at = now()-        WHERE workflow_id = $1-          AND workflow_name = $2-          AND status NOT IN ('completed', 'cancelled', 'failed')-        RETURNING attempts-        """-        ( contrazip3-            (E.param (E.nonNullable E.text))-            (E.param (E.nonNullable E.text))-            (E.param (E.nonNullable E.text))-        )-        (D.singleRow (D.column (D.nonNullable D.int4)))+  preparable+    """+    UPDATE keiro.keiro_workflows+    SET attempts = attempts + 1,+        last_error = $3,+        next_attempt_at = now() + (LEAST(power(2, attempts + 1), 64) * interval '1 second'),+        updated_at = now()+    WHERE workflow_id = $1+      AND workflow_name = $2+      AND status NOT IN ('completed', 'cancelled', 'failed')+    RETURNING attempts+    """+    ( contrazip3+        (E.param (E.nonNullable E.text))+        (E.param (E.nonNullable E.text))+        (E.param (E.nonNullable E.text))+    )+    (D.singleRow (D.column (D.nonNullable D.int4)))  resetInstanceAttemptsStmt :: Statement (Text, Text) () resetInstanceAttemptsStmt =-    preparable-        """-        UPDATE keiro.keiro_workflows-        SET attempts = 0,-            last_error = NULL,-            next_attempt_at = NULL,-            updated_at = now()-        WHERE workflow_id = $1-          AND workflow_name = $2-          AND status NOT IN ('completed', 'cancelled', 'failed')-        """-        ( contrazip2-            (E.param (E.nonNullable E.text))-            (E.param (E.nonNullable E.text))-        )-        D.noResult+  preparable+    """+    UPDATE keiro.keiro_workflows+    SET attempts = 0,+        last_error = NULL,+        next_attempt_at = NULL,+        updated_at = now()+    WHERE workflow_id = $1+      AND workflow_name = $2+      AND status NOT IN ('completed', 'cancelled', 'failed')+    """+    ( contrazip2+        (E.param (E.nonNullable E.text))+        (E.param (E.nonNullable E.text))+    )+    D.noResult  reviveFailedInstanceStmt :: Statement (Text, Text) Bool reviveFailedInstanceStmt =-    preparable-        """-        UPDATE keiro.keiro_workflows-        SET status = 'running',-            attempts = 0,-            last_error = NULL,-            next_attempt_at = NULL,-            leased_by = NULL,-            lease_expires_at = NULL,-            completed_at = NULL,-            updated_at = now()-        WHERE workflow_id = $1-          AND workflow_name = $2-          AND status = 'failed'-        """-        ( contrazip2-            (E.param (E.nonNullable E.text))-            (E.param (E.nonNullable E.text))-        )-        ((> 0) <$> D.rowsAffected)+  preparable+    """+    UPDATE keiro.keiro_workflows+    SET status = 'running',+        attempts = 0,+        last_error = NULL,+        next_attempt_at = NULL,+        leased_by = NULL,+        lease_expires_at = NULL,+        completed_at = NULL,+        updated_at = now()+    WHERE workflow_id = $1+      AND workflow_name = $2+      AND status = 'failed'+    """+    ( contrazip2+        (E.param (E.nonNullable E.text))+        (E.param (E.nonNullable E.text))+    )+    ((> 0) <$> D.rowsAffected)  instanceRowDecoder :: D.Row WorkflowInstanceRow instanceRowDecoder =-    WorkflowInstanceRow-        <$> D.column (D.nonNullable D.text)-        <*> D.column (D.nonNullable D.text)-        <*> D.column (D.nonNullable D.int4)-        <*> (statusFromText <$> D.column (D.nonNullable D.text))-        <*> D.column (D.nonNullable D.int4)-        <*> D.column (D.nullable D.text)-        <*> D.column (D.nullable D.timestamptz)-        <*> D.column (D.nullable D.text)-        <*> D.column (D.nullable D.timestamptz)-        <*> D.column (D.nonNullable D.timestamptz)-        <*> D.column (D.nonNullable D.timestamptz)-        <*> D.column (D.nullable D.timestamptz)+  WorkflowInstanceRow+    <$> D.column (D.nonNullable D.text)+    <*> D.column (D.nonNullable D.text)+    <*> D.column (D.nonNullable D.int4)+    <*> (statusFromText <$> D.column (D.nonNullable D.text))+    <*> D.column (D.nonNullable D.int4)+    <*> D.column (D.nullable D.text)+    <*> D.column (D.nullable D.timestamptz)+    <*> D.column (D.nullable D.text)+    <*> D.column (D.nullable D.timestamptz)+    <*> D.column (D.nonNullable D.timestamptz)+    <*> D.column (D.nonNullable D.timestamptz)+    <*> D.column (D.nullable D.timestamptz)
src/Keiro/Workflow/Resume.hs view
@@ -1,66 +1,65 @@-{- | The workflow resume / crash-recovery worker.--EP-38 makes a workflow replay-on-re-invocation: call 'runWorkflow' (or-'runWorkflowWith') with the same id and each already-journaled step-short-circuits, so only the un-journaled tail runs. But nothing in the runtime-/notices/ that a workflow exists, has steps, and lacks a terminal-'WorkflowCompleted' — i.e. that it crashed mid-run, or is parked on a-@sleep@\/@awakeable@ whose wake source has since resolved. This module is what-notices: a background worker that, on each pass, asks the database "which-workflows have steps but no completion?" ('findUnfinishedWorkflowIds') and-re-invokes each so it proceeds.--Synchronous exceptions are retried with database-backed exponential backoff.-Once 'maxAttempts' is reached, the worker appends 'WorkflowFailed' and stops-discovering that instance. The operator-facing counterpart lives in-"Keiro.Workflow.Instance": 'Keiro.Workflow.Instance.resurrectFailedWorkflow'-transactionally returns a terminally failed instance to the runnable pool-without deleting its append-only failure history.--== Why a registry--A workflow's body is application Haskell code — only its /journal/ (the-recorded step results) lives in the database. To re-invoke a workflow the-worker must turn its stored name into a function-@'WorkflowId' -> 'Eff' ('Workflow' : es) a@. There is no way to materialize a-closure from a string, so the application supplies a 'WorkflowRegistry' mapping-each 'WorkflowName' to its 'WorkflowDef'. This is the resume-worker analogue of-the caller-supplied @fire@ action 'Keiro.Timer.runTimerWorker' takes: the-worker owns the discovery loop and the database access; the application owns-the domain behaviour.--== Contract recap for downstream plans (the v2 MasterPlan)--* __'WorkflowRegistry' \/ 'WorkflowDef'__ — the application-supplied-  name → definition map. EP-43 (child workflows) relies on this worker to wake-  a /parent/ once a child finishes: the child's completion journals the-  parent's awaited @child:\<id\>@ 'StepRecorded', and the next resume pass-  re-invokes the parent (registered here) so it proceeds past its child-wait.-* __'ResumeSummary'__ ('discovered', 'resumed', 'completed', 'stillSuspended',-  'unknownName', 'failed', 'transientErrors', 'leaseSkipped') — the per-pass-  observability record. EP-44 reads it for the @keiro.workflow.resumed@-  instrument (and may thread a @Maybe KeiroMetrics@ into-  'WorkflowResumeOptions' \/ 'resumeWorkflowsOnce' following the-  no-op-under-@Nothing@ idiom the timer and outbox workers use).-* __'resumeWorkflowsOnce'__ is the single-pass, testable unit (like-  'Keiro.Outbox.publishClaimedOutbox'); __'runWorkflowResumeWorker'__ \/-  __'runWorkflowResumeWorkerWith'__ are the poll-loop drivers (like the-  @runTimerWorker@ pair). Re-invocation goes through EP-41's 'runWorkflowWith'-  carrying 'runOptions', so a resumed run honours the same snapshot/telemetry-  options as its first run.--Discovery is the 'findUnfinishedWorkflowIds' index query plus the child-row-seed query. Each candidate is claimed through an expiry-based row lease in-@keiro_workflows@ before it is advanced. A live foreign lease skips only that-instance and increments 'leaseSkipped'; a dead worker's lease becomes claimable-after 'leaseTtl'. Each fresh workflow boundary renews the lease before running-side effects. The lease prevents duplicate steady-state work, while the journal-append path still serializes same-step writers so lease expiry races converge-on one recorded result. There is __no kiroku @wf:@ prefix subscription__ and no-session-level advisory lock.--}-module Keiro.Workflow.Resume (-    -- * Registry+-- | The workflow resume / crash-recovery worker.+--+-- EP-38 makes a workflow replay-on-re-invocation: call 'runWorkflow' (or+-- 'runWorkflowWith') with the same id and each already-journaled step+-- short-circuits, so only the un-journaled tail runs. But nothing in the runtime+-- /notices/ that a workflow exists, has steps, and lacks a terminal+-- 'WorkflowCompleted' — i.e. that it crashed mid-run, or is parked on a+-- @sleep@\/@awakeable@ whose wake source has since resolved. This module is what+-- notices: a background worker that, on each pass, asks the database "which+-- workflows have steps but no completion?" ('findUnfinishedWorkflowIds') and+-- re-invokes each so it proceeds.+--+-- Synchronous exceptions are retried with database-backed exponential backoff.+-- Once 'maxAttempts' is reached, the worker appends 'WorkflowFailed' and stops+-- discovering that instance. The operator-facing counterpart lives in+-- "Keiro.Workflow.Instance": 'Keiro.Workflow.Instance.resurrectFailedWorkflow'+-- transactionally returns a terminally failed instance to the runnable pool+-- without deleting its append-only failure history.+--+-- == Why a registry+--+-- A workflow's body is application Haskell code — only its /journal/ (the+-- recorded step results) lives in the database. To re-invoke a workflow the+-- worker must turn its stored name into a function+-- @'WorkflowId' -> 'Eff' ('Workflow' : es) a@. There is no way to materialize a+-- closure from a string, so the application supplies a 'WorkflowRegistry' mapping+-- each 'WorkflowName' to its 'WorkflowDef'. This is the resume-worker analogue of+-- the caller-supplied @fire@ action 'Keiro.Timer.runTimerWorker' takes: the+-- worker owns the discovery loop and the database access; the application owns+-- the domain behaviour.+--+-- == Contract recap for downstream plans (the v2 MasterPlan)+--+-- * __'WorkflowRegistry' \/ 'WorkflowDef'__ — the application-supplied+--   name → definition map. EP-43 (child workflows) relies on this worker to wake+--   a /parent/ once a child finishes: the child's completion journals the+--   parent's awaited @child:\<id\>@ 'StepRecorded', and the next resume pass+--   re-invokes the parent (registered here) so it proceeds past its child-wait.+-- * __'ResumeSummary'__ ('discovered', 'resumed', 'completed', 'stillSuspended',+--   'unknownName', 'failed', 'transientErrors', 'leaseSkipped') — the per-pass+--   observability record. EP-44 reads it for the @keiro.workflow.resumed@+--   instrument (and may thread a @Maybe KeiroMetrics@ into+--   'WorkflowResumeOptions' \/ 'resumeWorkflowsOnce' following the+--   no-op-under-@Nothing@ idiom the timer and outbox workers use).+-- * __'resumeWorkflowsOnce'__ is the single-pass, testable unit (like+--   'Keiro.Outbox.publishClaimedOutbox'); __'runWorkflowResumeWorker'__ \/+--   __'runWorkflowResumeWorkerWith'__ are the poll-loop drivers (like the+--   @runTimerWorker@ pair). Re-invocation goes through EP-41's 'runWorkflowWith'+--   carrying 'runOptions', so a resumed run honours the same snapshot/telemetry+--   options as its first run.+--+-- Discovery is the 'findUnfinishedWorkflowIds' index query plus the child-row+-- seed query. Each candidate is claimed through an expiry-based row lease in+-- @keiro_workflows@ before it is advanced. A live foreign lease skips only that+-- instance and increments 'leaseSkipped'; a dead worker's lease becomes claimable+-- after 'leaseTtl'. Each fresh workflow boundary renews the lease before running+-- side effects. The lease prevents duplicate steady-state work, while the journal+-- append path still serializes same-step writers so lease expiry races converge+-- on one recorded result. There is __no kiroku @wf:@ prefix subscription__ and no+-- session-level advisory lock.+module Keiro.Workflow.Resume+  ( -- * Registry     WorkflowDef (..),     WorkflowRegistry, @@ -81,7 +80,7 @@     -- * Running (push-aware, EP-50)     runPollLoopWith,     runWorkflowResumeWorkerPush,-)+  ) where  import Control.Concurrent (threadDelay)@@ -101,16 +100,16 @@ import Effectful.Error.Static qualified as Error import Effectful.Exception (catch, catchSync, finally, throwIO) import Keiro.Prelude-import Keiro.Telemetry (-    recordWorkflowAwakeablesPending,+import Keiro.Telemetry+  ( recordWorkflowAwakeablesPending,     recordWorkflowFailed,     recordWorkflowLeaseSkipped,     recordWorkflowResumeErrors,     recordWorkflowResumed,- )+  ) import Keiro.Wake (WakeSignal (..), wakeSignalFromStore)-import Keiro.Workflow (-    JournalAppendOutcome (..),+import Keiro.Workflow+  ( JournalAppendOutcome (..),     LeaseHeartbeat (..),     Workflow,     WorkflowError (..),@@ -126,7 +125,7 @@     findUnfinishedWorkflowIds,     prepareJournalAppend,     runWorkflowWith,- )+  ) import Keiro.Workflow.Awakeable.Schema (countPendingAwakeables) import Keiro.Workflow.Child (runChildWorkflow) import Keiro.Workflow.Child.Schema (ChildRow, findRunningChildIds, lookupChild, markChildFailedTx)@@ -142,133 +141,127 @@ -- Registry -- --------------------------------------------------------------------------- -{- | How to re-build a workflow's body from its id, for one workflow name.--The result type @a@ is existential: the worker discards it (it cares only-whether a re-invocation reached 'Completed' or 'Suspended'), so one registry-can hold workflows of different return types.--}+-- | How to re-build a workflow's body from its id, for one workflow name.+--+-- The result type @a@ is existential: the worker discards it (it cares only+-- whether a re-invocation reached 'Completed' or 'Suspended'), so one registry+-- can hold workflows of different return types. data WorkflowDef es = forall a. (Aeson.ToJSON a) => WorkflowDef-    { runDef :: WorkflowId -> Eff (Workflow : es) a-    }+  { runDef :: WorkflowId -> Eff (Workflow : es) a+  } -{- | The application-supplied map from workflow name to its definition. The-worker looks up each discovered workflow's name here; an absent name is-skipped and counted as 'unknownName' (a deploy that dropped a workflow while-instances were still in flight — surfaced, not silently lost).--}+-- | The application-supplied map from workflow name to its definition. The+-- worker looks up each discovered workflow's name here; an absent name is+-- skipped and counted as 'unknownName' (a deploy that dropped a workflow while+-- instances were still in flight — surfaced, not silently lost). type WorkflowRegistry es = Map WorkflowName (WorkflowDef es)  -- --------------------------------------------------------------------------- -- Options -- --------------------------------------------------------------------------- -{- | Options for the resume worker. Mirrors the @TimerWorkerOptions@ shape:-'runOptions' threads EP-41's snapshot/telemetry options into 'runWorkflowWith',-and 'pollInterval' is the loop driver's gap between passes.--}+-- | Options for the resume worker. Mirrors the @TimerWorkerOptions@ shape:+-- 'runOptions' threads EP-41's snapshot/telemetry options into 'runWorkflowWith',+-- and 'pollInterval' is the loop driver's gap between passes. data WorkflowResumeOptions = WorkflowResumeOptions-    { runOptions :: !WorkflowRunOptions-    {- ^ Threaded into 'runWorkflowWith' (or 'runChildWorkflow' for a child) so a-    resumed run honours the same snapshot (EP-41) and telemetry (EP-44)-    options as its first run.-    -}-    , pollInterval :: !Int-    -- ^ Microseconds the loop driver sleeps between passes.-    , maxAttempts :: !Int-    -- ^ Workflow-level synchronous exceptions before terminal failure.-    , leaseTtl :: !NominalDiffTime-    {- ^ How long a claimed workflow instance stays leased without reaching-    another fresh workflow boundary. It bounds dead-worker recovery time and-    must exceed the longest single step action or await arm.-    -}-    , logEvent :: !(ResumeLogEvent -> IO ())-    -- ^ Per-worker logging hook. Defaults to a compact stderr renderer.-    }-    deriving stock (Generic)+  { -- | Threaded into 'runWorkflowWith' (or 'runChildWorkflow' for a child) so a+    --     resumed run honours the same snapshot (EP-41) and telemetry (EP-44)+    --     options as its first run.+    runOptions :: !WorkflowRunOptions,+    -- | Microseconds the loop driver sleeps between passes.+    pollInterval :: !Int,+    -- | Workflow-level synchronous exceptions before terminal failure.+    maxAttempts :: !Int,+    -- | How long a claimed workflow instance stays leased without reaching+    --     another fresh workflow boundary. It bounds dead-worker recovery time and+    --     must exceed the longest single step action or await arm.+    leaseTtl :: !NominalDiffTime,+    -- | Per-worker logging hook. Defaults to a compact stderr renderer.+    logEvent :: !(ResumeLogEvent -> IO ())+  }+  deriving stock (Generic)  data ResumeLogEvent-    = ResumeUnknownName !Text !Text-    | ResumeTransientError !Text !Text !Text-    | ResumeWorkflowCrashed !Text !Text !Int !Int !Text-    | ResumeWorkflowMarkedFailed !Text !Text !Text-    | ResumePassFailed !Text-    deriving stock (Eq, Show)+  = ResumeUnknownName !Text !Text+  | ResumeTransientError !Text !Text !Text+  | ResumeWorkflowCrashed !Text !Text !Int !Int !Text+  | ResumeWorkflowMarkedFailed !Text !Text !Text+  | ResumePassFailed !Text+  deriving stock (Eq, Show)  -- | Defaults: EP-41's 'defaultWorkflowRunOptions', a 1-second poll, and a 60-second lease. defaultWorkflowResumeOptions :: WorkflowResumeOptions defaultWorkflowResumeOptions =-    WorkflowResumeOptions-        { runOptions = defaultWorkflowRunOptions-        , pollInterval = 1_000_000-        , maxAttempts = 5-        , leaseTtl = 60-        , logEvent = defaultResumeLogEvent-        }+  WorkflowResumeOptions+    { runOptions = defaultWorkflowRunOptions,+      pollInterval = 1_000_000,+      maxAttempts = 5,+      leaseTtl = 60,+      logEvent = defaultResumeLogEvent+    }  defaultResumeLogEvent :: ResumeLogEvent -> IO () defaultResumeLogEvent event =-    hPutStrLn stderr $ case event of-        ResumeUnknownName name wid ->-            "keiro resume worker: no registry entry for workflow "-                <> Text.unpack name-                <> " (id "-                <> Text.unpack wid-                <> "); skipping"-        ResumeTransientError name wid err ->-            "keiro resume worker: transient store error while advancing "-                <> Text.unpack name-                <> " (id "-                <> Text.unpack wid-                <> "): "-                <> Text.unpack err-        ResumeWorkflowCrashed name wid attempt maxAttempt err ->-            "keiro resume worker: workflow "-                <> Text.unpack name-                <> " (id "-                <> Text.unpack wid-                <> ") crashed on attempt "-                <> show attempt-                <> "/"-                <> show maxAttempt-                <> ": "-                <> Text.unpack err-        ResumeWorkflowMarkedFailed name wid err ->-            "keiro resume worker: marked workflow "-                <> Text.unpack name-                <> " (id "-                <> Text.unpack wid-                <> ") failed: "-                <> Text.unpack err-        ResumePassFailed err ->-            "keiro resume worker: pass failed: " <> Text.unpack err+  hPutStrLn stderr $ case event of+    ResumeUnknownName name wid ->+      "keiro resume worker: no registry entry for workflow "+        <> Text.unpack name+        <> " (id "+        <> Text.unpack wid+        <> "); skipping"+    ResumeTransientError name wid err ->+      "keiro resume worker: transient store error while advancing "+        <> Text.unpack name+        <> " (id "+        <> Text.unpack wid+        <> "): "+        <> Text.unpack err+    ResumeWorkflowCrashed name wid attempt maxAttempt err ->+      "keiro resume worker: workflow "+        <> Text.unpack name+        <> " (id "+        <> Text.unpack wid+        <> ") crashed on attempt "+        <> show attempt+        <> "/"+        <> show maxAttempt+        <> ": "+        <> Text.unpack err+    ResumeWorkflowMarkedFailed name wid err ->+      "keiro resume worker: marked workflow "+        <> Text.unpack name+        <> " (id "+        <> Text.unpack wid+        <> ") failed: "+        <> Text.unpack err+    ResumePassFailed err ->+      "keiro resume worker: pass failed: " <> Text.unpack err  -- --------------------------------------------------------------------------- -- Per-pass summary -- --------------------------------------------------------------------------- -{- | What one 'resumeWorkflowsOnce' pass did. EP-44 instruments this for-@keiro.workflow.resumed@.--}+-- | What one 'resumeWorkflowsOnce' pass did. EP-44 instruments this for+-- @keiro.workflow.resumed@. data ResumeSummary = ResumeSummary-    { discovered :: !Int-    -- ^ Unfinished workflows 'findUnfinishedWorkflowIds' returned this pass.-    , resumed :: !Int-    -- ^ Workflows re-invoked (found in the registry and run).-    , completed :: !Int-    -- ^ Re-invocations that reached 'Completed' this pass.-    , stillSuspended :: !Int-    -- ^ Re-invocations that returned 'Suspended' (wake source not yet resolved).-    , unknownName :: !Int-    -- ^ Discovered workflows whose name was absent from the registry (skipped + logged).-    , failed :: !Int-    -- ^ Workflows marked terminally failed this pass.-    , transientErrors :: !Int-    -- ^ Store errors observed while advancing individual workflows.-    , leaseSkipped :: !Int-    -- ^ Candidates skipped because another worker holds a live lease.-    }-    deriving stock (Generic, Eq, Show)+  { -- | Unfinished workflows 'findUnfinishedWorkflowIds' returned this pass.+    discovered :: !Int,+    -- | Workflows re-invoked (found in the registry and run).+    resumed :: !Int,+    -- | Re-invocations that reached 'Completed' this pass.+    completed :: !Int,+    -- | Re-invocations that returned 'Suspended' (wake source not yet resolved).+    stillSuspended :: !Int,+    -- | Discovered workflows whose name was absent from the registry (skipped + logged).+    unknownName :: !Int,+    -- | Workflows marked terminally failed this pass.+    failed :: !Int,+    -- | Store errors observed while advancing individual workflows.+    transientErrors :: !Int,+    -- | Candidates skipped because another worker holds a live lease.+    leaseSkipped :: !Int+  }+  deriving stock (Generic, Eq, Show)  -- | A zeroed 'ResumeSummary'. emptyResumeSummary :: ResumeSummary@@ -278,45 +271,44 @@ -- Running -- --------------------------------------------------------------------------- -{- | Run one discover-and-reinvoke pass.--Discovers every unfinished workflow via 'findUnfinishedWorkflowIds', and for-each looks its name up in @registry@:--* __present__ — re-invoke through 'runWorkflowWith' (the journal pre-load-  short-circuits already-journaled steps, so only the un-journaled tail runs);-  the outcome bumps 'completed' or 'stillSuspended'.-* __absent__ — log a warning and bump 'unknownName' (a workflow whose code was-  removed while instances were in flight must be visible, not silently lost).--Idempotent: a completed workflow has a @__workflow_completed__@ index row and-so drops out of discovery; re-invoking an unfinished one twice converges to the-same journal (EP-38 deterministic ids + step short-circuit).--}+-- | Run one discover-and-reinvoke pass.+--+-- Discovers every unfinished workflow via 'findUnfinishedWorkflowIds', and for+-- each looks its name up in @registry@:+--+-- * __present__ — re-invoke through 'runWorkflowWith' (the journal pre-load+--   short-circuits already-journaled steps, so only the un-journaled tail runs);+--   the outcome bumps 'completed' or 'stillSuspended'.+-- * __absent__ — log a warning and bump 'unknownName' (a workflow whose code was+--   removed while instances were in flight must be visible, not silently lost).+--+-- Idempotent: a completed workflow has a @__workflow_completed__@ index row and+-- so drops out of discovery; re-invoking an unfinished one twice converges to the+-- same journal (EP-38 deterministic ids + step short-circuit). resumeWorkflowsOnce ::-    forall es.-    (IOE :> es, Store :> es, Error StoreError :> es) =>-    WorkflowResumeOptions ->-    WorkflowRegistry es ->-    Eff es ResumeSummary+  forall es.+  (IOE :> es, Store :> es, Error StoreError :> es) =>+  WorkflowResumeOptions ->+  WorkflowRegistry es ->+  Eff es ResumeSummary resumeWorkflowsOnce opts registry = do-    -- EP-44: sample the @keiro.workflow.awakeables.pending@ gauge once per pass,-    -- on the same Store the discovery query uses. The metrics handle rides on the-    -- run options (EP-44 threads telemetry through 'WorkflowRunOptions'), so it is-    -- already forwarded into 'runWorkflowWith' for every re-invocation.-    pending <- countPendingAwakeables-    recordWorkflowAwakeablesPending mMetrics (fromIntegral pending)-    -- Discovery unions two sources: workflows with steps but no terminal marker-    -- ('findUnfinishedWorkflowIds') and freshly-spawned children that have no-    -- step rows yet ('findRunningChildIds', EP-43) — so a zero-step child is-    -- still driven. The dedup collapses a child that appears in both.-    now <- liftIO getCurrentTime-    unfinished <- findUnfinishedWorkflowIds now-    runningChildren <- findRunningChildIds-    let pairs = dedupeFirstSeen (unfinished <> runningChildren)-        seed = emptyResumeSummary{discovered = length pairs}-    owner <- UUID.toText <$> liftIO UUIDv4.nextRandom-    foldM (advance owner) seed pairs+  -- EP-44: sample the @keiro.workflow.awakeables.pending@ gauge once per pass,+  -- on the same Store the discovery query uses. The metrics handle rides on the+  -- run options (EP-44 threads telemetry through 'WorkflowRunOptions'), so it is+  -- already forwarded into 'runWorkflowWith' for every re-invocation.+  pending <- countPendingAwakeables+  recordWorkflowAwakeablesPending mMetrics (fromIntegral pending)+  -- Discovery unions two sources: workflows with steps but no terminal marker+  -- ('findUnfinishedWorkflowIds') and freshly-spawned children that have no+  -- step rows yet ('findRunningChildIds', EP-43) — so a zero-step child is+  -- still driven. The dedup collapses a child that appears in both.+  now <- liftIO getCurrentTime+  unfinished <- findUnfinishedWorkflowIds now+  runningChildren <- findRunningChildIds+  let pairs = dedupeFirstSeen (unfinished <> runningChildren)+      seed = emptyResumeSummary {discovered = length pairs}+  owner <- UUID.toText <$> liftIO UUIDv4.nextRandom+  foldM (advance owner) seed pairs   where     mMetrics = runOptions opts ^. #metrics     dedupeFirstSeen :: [(Text, Text)] -> [(Text, Text)]@@ -324,241 +316,237 @@       where         go !_ [] = []         go !seen (pair : rest)-            | pair `Set.member` seen = go seen rest-            | otherwise = pair : go (Set.insert pair seen) rest+          | pair `Set.member` seen = go seen rest+          | otherwise = pair : go (Set.insert pair seen) rest      advance :: Text -> ResumeSummary -> (Text, Text) -> Eff es ResumeSummary     advance owner acc (widText, wnameText) =-        case Map.lookup (WorkflowName wnameText) registry of-            Nothing -> do-                liftIO $ logEvent opts (ResumeUnknownName wnameText widText)-                pure acc{unknownName = unknownName acc + 1}-            Just (WorkflowDef runDef) -> do-                let wid = WorkflowId widText-                    name = WorkflowName wnameText-                claimed <- claimInstance owner (leaseTtl opts) name wid-                if not claimed-                    then do-                        recordWorkflowLeaseSkipped mMetrics 1-                        pure acc{leaseSkipped = leaseSkipped acc + 1}-                    else do-                        progressedRef <- liftIO (newIORef False)-                        ( do-                                attempt <--                                    Error.catchError-                                        @StoreError-                                        (AdvOk <$> driveInstance owner name wid runDef)-                                        (\_ e -> pure (AdvTransient e))-                                        `catch` (\WorkflowLeaseLost -> pure AdvLeaseLost)-                                        `catchSync` (pure . AdvCrashed)-                                recordWorkflowResumed mMetrics 1-                                (acc', progressed) <- handleAttempt acc name wid attempt-                                liftIO (writeIORef progressedRef progressed)-                                pure acc'-                            )-                            `finally` do-                                progressed <- liftIO (readIORef progressedRef)-                                releaseInstance owner progressed name wid+      case Map.lookup (WorkflowName wnameText) registry of+        Nothing -> do+          liftIO $ logEvent opts (ResumeUnknownName wnameText widText)+          pure acc {unknownName = unknownName acc + 1}+        Just (WorkflowDef runDef) -> do+          let wid = WorkflowId widText+              name = WorkflowName wnameText+          claimed <- claimInstance owner (leaseTtl opts) name wid+          if not claimed+            then do+              recordWorkflowLeaseSkipped mMetrics 1+              pure acc {leaseSkipped = leaseSkipped acc + 1}+            else do+              progressedRef <- liftIO (newIORef False)+              ( do+                  attempt <-+                    Error.catchError+                      @StoreError+                      (AdvOk <$> driveInstance owner name wid runDef)+                      (\_ e -> pure (AdvTransient e))+                      `catch` (\WorkflowLeaseLost -> pure AdvLeaseLost)+                      `catchSync` (pure . AdvCrashed)+                  recordWorkflowResumed mMetrics 1+                  (acc', progressed) <- handleAttempt acc name wid attempt+                  liftIO (writeIORef progressedRef progressed)+                  pure acc'+                )+                `finally` do+                  progressed <- liftIO (readIORef progressedRef)+                  releaseInstance owner progressed name wid     driveInstance :: (Aeson.ToJSON a) => Text -> WorkflowName -> WorkflowId -> (WorkflowId -> Eff (Workflow : es) a) -> Eff es (WorkflowOutcome a)     driveInstance owner name@(WorkflowName wnameText) wid@(WorkflowId widText) runDef = do-        mChild <- lookupChild widText wnameText-        let runOpts =-                runOptions opts-                    & #leaseHeartbeat-                    .~ Just LeaseHeartbeat{owner, ttl = leaseTtl opts}-        case mChild of-            Just _ -> runChildWorkflow runOpts name wid (runDef wid)-            Nothing -> runWorkflowWith runOpts name wid (runDef wid)+      mChild <- lookupChild widText wnameText+      let runOpts =+            runOptions opts+              & #leaseHeartbeat+              .~ Just LeaseHeartbeat {owner, ttl = leaseTtl opts}+      case mChild of+        Just _ -> runChildWorkflow runOpts name wid (runDef wid)+        Nothing -> runWorkflowWith runOpts name wid (runDef wid)     handleAttempt :: ResumeSummary -> WorkflowName -> WorkflowId -> AdvanceResult a -> Eff es (ResumeSummary, Bool)     handleAttempt acc name@(WorkflowName wnameText) wid@(WorkflowId widText) = \case-        AdvOk outcome -> do-            pure (bumpForOutcome outcome acc, True)-        AdvTransient err -> do-            let rendered = Text.pack (show err)-            liftIO $ logEvent opts (ResumeTransientError wnameText widText rendered)-            recordWorkflowResumeErrors mMetrics 1-            pure (acc{resumed = resumed acc + 1, transientErrors = transientErrors acc + 1}, False)-        AdvLeaseLost -> do-            recordWorkflowLeaseSkipped mMetrics 1-            pure (acc{leaseSkipped = leaseSkipped acc + 1}, False)-        AdvCrashed err -> do-            let rendered = Text.pack (show err)-            attempt <- runTransaction (recordCrashTx widText wnameText rendered)-            liftIO $ logEvent opts (ResumeWorkflowCrashed wnameText widText (fromIntegral attempt) (maxAttempts opts) rendered)-            if attempt >= fromIntegral (maxAttempts opts :: Int)-                then do-                    now <- liftIO getCurrentTime-                    mChild <- lookupChild widText wnameText-                    case mChild of-                        Nothing ->-                            appendJournalEntry name wid (WorkflowFailed rendered now)-                        Just childRow ->-                            appendFailedChildAndWakeParent name wid rendered now childRow-                    liftIO $ logEvent opts (ResumeWorkflowMarkedFailed wnameText widText rendered)-                    recordWorkflowFailed mMetrics 1-                    pure (acc{resumed = resumed acc + 1, failed = failed acc + 1}, False)-                else pure (acc{resumed = resumed acc + 1}, False)+      AdvOk outcome -> do+        pure (bumpForOutcome outcome acc, True)+      AdvTransient err -> do+        let rendered = Text.pack (show err)+        liftIO $ logEvent opts (ResumeTransientError wnameText widText rendered)+        recordWorkflowResumeErrors mMetrics 1+        pure (acc {resumed = resumed acc + 1, transientErrors = transientErrors acc + 1}, False)+      AdvLeaseLost -> do+        recordWorkflowLeaseSkipped mMetrics 1+        pure (acc {leaseSkipped = leaseSkipped acc + 1}, False)+      AdvCrashed err -> do+        let rendered = Text.pack (show err)+        attempt <- runTransaction (recordCrashTx widText wnameText rendered)+        liftIO $ logEvent opts (ResumeWorkflowCrashed wnameText widText (fromIntegral attempt) (maxAttempts opts) rendered)+        if attempt >= fromIntegral (maxAttempts opts :: Int)+          then do+            now <- liftIO getCurrentTime+            mChild <- lookupChild widText wnameText+            case mChild of+              Nothing ->+                appendJournalEntry name wid (WorkflowFailed rendered now)+              Just childRow ->+                appendFailedChildAndWakeParent name wid rendered now childRow+            liftIO $ logEvent opts (ResumeWorkflowMarkedFailed wnameText widText rendered)+            recordWorkflowFailed mMetrics 1+            pure (acc {resumed = resumed acc + 1, failed = failed acc + 1}, False)+          else pure (acc {resumed = resumed acc + 1}, False)  data AdvanceResult a-    = AdvOk !(WorkflowOutcome a)-    | AdvTransient !StoreError-    | AdvLeaseLost-    | AdvCrashed !Exception.SomeException+  = AdvOk !(WorkflowOutcome a)+  | AdvTransient !StoreError+  | AdvLeaseLost+  | AdvCrashed !Exception.SomeException  appendFailedChildAndWakeParent ::-    (IOE :> es, Store :> es) =>-    WorkflowName ->-    WorkflowId ->-    Text ->-    UTCTime ->-    ChildRow ->-    Eff es ()+  (IOE :> es, Store :> es) =>+  WorkflowName ->+  WorkflowId ->+  Text ->+  UTCTime ->+  ChildRow ->+  Eff es () appendFailedChildAndWakeParent childNm childWid reason now childRow = do-    childGen <- currentGeneration childNm childWid-    let parentNm = WorkflowName (childRow ^. #parentName)-        parentWid = WorkflowId (childRow ^. #parentId)-    parentGen <- currentGeneration parentNm parentWid-    childFailTx <- prepareJournalAppend childNm childWid childGen (WorkflowFailed reason now)-    parentWakeTx <--        prepareJournalAppend-            parentNm-            parentWid-            parentGen-            StepRecorded-                { stepName = childRow ^. #awaitStep-                , result = Aeson.object ["failed" Aeson..= reason]-                , recordedAt = now-                }-    (childOutcome, parentOutcome) <--        runTransaction $ do-            childOutcome <- childFailTx-            _transitioned <- markChildFailedTx (unWorkflowId childWid) (unWorkflowName childNm) reason-            parentOutcome <- parentWakeTx-            condemnOnAppendConflict childOutcome-            condemnOnAppendConflict parentOutcome-            pure (childOutcome, parentOutcome)-    throwOnAppendConflict childOutcome-    throwOnAppendConflict parentOutcome+  childGen <- currentGeneration childNm childWid+  let parentNm = WorkflowName (childRow ^. #parentName)+      parentWid = WorkflowId (childRow ^. #parentId)+  parentGen <- currentGeneration parentNm parentWid+  childFailTx <- prepareJournalAppend childNm childWid childGen (WorkflowFailed reason now)+  parentWakeTx <-+    prepareJournalAppend+      parentNm+      parentWid+      parentGen+      StepRecorded+        { stepName = childRow ^. #awaitStep,+          result = Aeson.object ["failed" Aeson..= reason],+          recordedAt = now+        }+  (childOutcome, parentOutcome) <-+    runTransaction $ do+      childOutcome <- childFailTx+      _transitioned <- markChildFailedTx (unWorkflowId childWid) (unWorkflowName childNm) reason+      parentOutcome <- parentWakeTx+      condemnOnAppendConflict childOutcome+      condemnOnAppendConflict parentOutcome+      pure (childOutcome, parentOutcome)+  throwOnAppendConflict childOutcome+  throwOnAppendConflict parentOutcome  condemnOnAppendConflict :: JournalAppendOutcome -> Tx.Transaction () condemnOnAppendConflict = \case-    JournalAppendConflict{} -> Tx.condemn-    _ -> pure ()+  JournalAppendConflict {} -> Tx.condemn+  _ -> pure ()  throwOnAppendConflict :: JournalAppendOutcome -> Eff es () throwOnAppendConflict = \case-    JournalAppendConflict err -> throwIO (WorkflowJournalAppendError (Text.pack (show err)))-    _ -> pure ()+  JournalAppendConflict err -> throwIO (WorkflowJournalAppendError (Text.pack (show err)))+  _ -> pure () -{- | Fold one re-invocation's outcome into the running summary. The existential-result @a@ is discarded here, so it never escapes the registry.--}+-- | Fold one re-invocation's outcome into the running summary. The existential+-- result @a@ is discarded here, so it never escapes the registry. bumpForOutcome :: WorkflowOutcome a -> ResumeSummary -> ResumeSummary bumpForOutcome outcome acc = case outcome of-    Completed _ -> acc{resumed = resumed acc + 1, completed = completed acc + 1}-    Suspended -> acc{resumed = resumed acc + 1, stillSuspended = stillSuspended acc + 1}-    -- A workflow cancelled between discovery and re-invocation short-circuits to-    -- 'Cancelled' (EP-43); count it as re-invoked but neither completed nor-    -- suspended. (A cancelled workflow also drops out of discovery, so this is a-    -- rare race, not the steady state.)-    Cancelled -> acc{resumed = resumed acc + 1}-    Failed -> acc{resumed = resumed acc + 1}-    -- A workflow that rotated via continueAsNew (EP-48) returns 'ContinuedAsNew':-    -- it is re-invoked but neither completed nor suspended this pass. Its new-    -- generation has no terminal marker, so 'findUnfinishedWorkflowIds' still-    -- reports it and the next pass drives the rotated generation forward.-    ContinuedAsNew -> acc{resumed = resumed acc + 1}+  Completed _ -> acc {resumed = resumed acc + 1, completed = completed acc + 1}+  Suspended -> acc {resumed = resumed acc + 1, stillSuspended = stillSuspended acc + 1}+  -- A workflow cancelled between discovery and re-invocation short-circuits to+  -- 'Cancelled' (EP-43); count it as re-invoked but neither completed nor+  -- suspended. (A cancelled workflow also drops out of discovery, so this is a+  -- rare race, not the steady state.)+  Cancelled -> acc {resumed = resumed acc + 1}+  Failed -> acc {resumed = resumed acc + 1}+  -- A workflow that rotated via continueAsNew (EP-48) returns 'ContinuedAsNew':+  -- it is re-invoked but neither completed nor suspended this pass. Its new+  -- generation has no terminal marker, so 'findUnfinishedWorkflowIds' still+  -- reports it and the next pass drives the rotated generation forward.+  ContinuedAsNew -> acc {resumed = resumed acc + 1} -{- | Poll-and-resume loop: run 'resumeWorkflowsOnce' on the configured-'pollInterval' forever. Mirrors how an application schedules-'Keiro.Outbox.publishClaimedOutbox' \/ @runTimerWorker@ per tick; the-single-pass 'resumeWorkflowsOnce' remains the testable unit.--}+-- | Poll-and-resume loop: run 'resumeWorkflowsOnce' on the configured+-- 'pollInterval' forever. Mirrors how an application schedules+-- 'Keiro.Outbox.publishClaimedOutbox' \/ @runTimerWorker@ per tick; the+-- single-pass 'resumeWorkflowsOnce' remains the testable unit. runWorkflowResumeWorkerWith ::-    (IOE :> es, Store :> es, Error StoreError :> es) =>-    WorkflowResumeOptions ->-    WorkflowRegistry es ->-    Eff es ()+  (IOE :> es, Store :> es, Error StoreError :> es) =>+  WorkflowResumeOptions ->+  WorkflowRegistry es ->+  Eff es () runWorkflowResumeWorkerWith opts registry = forever $ do-    _summary <--        (Just <$> resumeWorkflowsOnce opts registry)-            `Error.catchError` (\_ (e :: StoreError) -> logPass (Text.pack (show e)))-            `catchSync` (logPass . Text.pack . show)-    liftIO (threadDelay (pollInterval opts))+  _summary <-+    (Just <$> resumeWorkflowsOnce opts registry)+      `Error.catchError` (\_ (e :: StoreError) -> logPass (Text.pack (show e)))+      `catchSync` (logPass . Text.pack . show)+  liftIO (threadDelay (pollInterval opts))   where     logPass msg = do-        liftIO $ logEvent opts (ResumePassFailed msg)-        pure Nothing+      liftIO $ logEvent opts (ResumePassFailed msg)+      pure Nothing  -- | 'runWorkflowResumeWorkerWith' with 'defaultWorkflowResumeOptions'. runWorkflowResumeWorker ::-    (IOE :> es, Store :> es, Error StoreError :> es) =>-    WorkflowRegistry es ->-    Eff es ()+  (IOE :> es, Store :> es, Error StoreError :> es) =>+  WorkflowRegistry es ->+  Eff es () runWorkflowResumeWorker = runWorkflowResumeWorkerWith defaultWorkflowResumeOptions  -- --------------------------------------------------------------------------- -- Push-aware loop (EP-50) -- --------------------------------------------------------------------------- -{- | Generic push-aware poll loop: run one pass, then block on the 'WakeSignal'-with the given fallback timeout (microseconds), forever. The pass is the durable-unit; the wake only shortens the gap between passes. Both wake reasons (a-notification or the fallback elapsing) mean "run another pass", so the returned-'Keiro.Wake.WakeReason' is ignored for control flow. A missed @NOTIFY@ costs at-most one fallback interval of latency, never lost work — correctness rests on the-pass (e.g. 'resumeWorkflowsOnce'), which is idempotent, not on a notification-arriving. The same pattern applies mechanically to 'Keiro.Timer.runTimerWorker'-and 'Keiro.Outbox.publishClaimedOutbox' (documented, not implemented here; the-resume worker carries the acceptance via parent/child cascades).--}+-- | Generic push-aware poll loop: run one pass, then block on the 'WakeSignal'+-- with the given fallback timeout (microseconds), forever. The pass is the durable+-- unit; the wake only shortens the gap between passes. Both wake reasons (a+-- notification or the fallback elapsing) mean "run another pass", so the returned+-- 'Keiro.Wake.WakeReason' is ignored for control flow. A missed @NOTIFY@ costs at+-- most one fallback interval of latency, never lost work — correctness rests on the+-- pass (e.g. 'resumeWorkflowsOnce'), which is idempotent, not on a notification+-- arriving. The same pattern applies mechanically to 'Keiro.Timer.runTimerWorker'+-- and 'Keiro.Outbox.publishClaimedOutbox' (documented, not implemented here; the+-- resume worker carries the acceptance via parent/child cascades). runPollLoopWith ::-    -- | the wake signal to block on between passes-    WakeSignal ->-    -- | fallback timeout in microseconds (the maximum gap when no notification arrives)-    Int ->-    -- | one pass, already wrapped to run in 'IO'-    IO () ->-    IO ()+  -- | the wake signal to block on between passes+  WakeSignal ->+  -- | fallback timeout in microseconds (the maximum gap when no notification arrives)+  Int ->+  -- | one pass, already wrapped to run in 'IO'+  IO () ->+  IO () runPollLoopWith wake fallbackMicros pass =-    forever (pass >> void (waitForWake wake fallbackMicros))--{- | The workflow resume worker, push-aware (EP-50). Runs 'resumeWorkflowsOnce'-on each pass; between passes it waits on the store's notifier (sub-second wake on-any append) and falls back to 'pollInterval' so a dropped notification still-drains the backlog.--This is the push-aware sibling of 'runWorkflowResumeWorker' /-'runWorkflowResumeWorkerWith', which remain unchanged as the durable fixed-poll-baseline. The 'pollInterval' field is __repurposed__ as the /fallback/ timeout:-its meaning shifts from "fixed gap between passes" to "maximum gap when no-notification arrives" — strictly better for latency, identical in the-no-notification worst case.+  forever (pass >> void (waitForWake wake fallbackMicros)) -It opens __no__ new database connection (the 'WakeSignal' rides kiroku's existing-single per-store listener; see "Keiro.Wake"). It takes the 'KirokuStore' handle-directly to reach that notifier, and runs each pass through-'Kiroku.Store.Effect.runStoreIO', which pins the registry's effect row to the-concrete @'[Store, Error StoreError, IOE]@ that @runStoreIO@ eliminates. A caller-needing a richer effect row can use 'runPollLoopWith' directly with their own-@runStoreIO@-equivalent pass.--}+-- | The workflow resume worker, push-aware (EP-50). Runs 'resumeWorkflowsOnce'+-- on each pass; between passes it waits on the store's notifier (sub-second wake on+-- any append) and falls back to 'pollInterval' so a dropped notification still+-- drains the backlog.+--+-- This is the push-aware sibling of 'runWorkflowResumeWorker' /+-- 'runWorkflowResumeWorkerWith', which remain unchanged as the durable fixed-poll+-- baseline. The 'pollInterval' field is __repurposed__ as the /fallback/ timeout:+-- its meaning shifts from "fixed gap between passes" to "maximum gap when no+-- notification arrives" — strictly better for latency, identical in the+-- no-notification worst case.+--+-- It opens __no__ new database connection (the 'WakeSignal' rides kiroku's existing+-- single per-store listener; see "Keiro.Wake"). It takes the 'KirokuStore' handle+-- directly to reach that notifier, and runs each pass through+-- 'Kiroku.Store.Effect.runStoreIO', which pins the registry's effect row to the+-- concrete @'[Store, Error StoreError, IOE]@ that @runStoreIO@ eliminates. A caller+-- needing a richer effect row can use 'runPollLoopWith' directly with their own+-- @runStoreIO@-equivalent pass. runWorkflowResumeWorkerPush ::-    KirokuStore ->-    WorkflowResumeOptions ->-    WorkflowRegistry '[Store, Error StoreError, IOE] ->-    IO ()+  KirokuStore ->+  WorkflowResumeOptions ->+  WorkflowRegistry '[Store, Error StoreError, IOE] ->+  IO () runWorkflowResumeWorkerPush store opts registry = do-    wake <- wakeSignalFromStore store-    runPollLoopWith wake (pollInterval opts) onePass+  wake <- wakeSignalFromStore store+  runPollLoopWith wake (pollInterval opts) onePass   where     onePass =-        handleSyncIO $-            runStoreIO store (resumeWorkflowsOnce opts registry) >>= \case-                Left err -> logEvent opts (ResumePassFailed (Text.pack (show err)))-                Right _ -> pure ()+      handleSyncIO $+        runStoreIO store (resumeWorkflowsOnce opts registry) >>= \case+          Left err -> logEvent opts (ResumePassFailed (Text.pack (show err)))+          Right _ -> pure ()     handleSyncIO action =-        action `Exception.catch` \err ->-            case Exception.fromException err of-                Just (async :: Exception.SomeAsyncException) -> Exception.throwIO async-                Nothing -> logEvent opts (ResumePassFailed (Text.pack (show (err :: Exception.SomeException))))+      action `Exception.catch` \err ->+        case Exception.fromException err of+          Just (async :: Exception.SomeAsyncException) -> Exception.throwIO async+          Nothing -> logEvent opts (ResumePassFailed (Text.pack (show (err :: Exception.SomeException))))
src/Keiro/Workflow/Schema.hs view
@@ -1,18 +1,17 @@-{- | The @keiro_workflow_steps@ table: the derived index of journaled-workflow steps.--The journal stream (@wf:\<name\>-\<id\>@) is the source of truth for replay;-this table is a fast-lookup view kept in sync inside the same transaction as-each journal append (see "Keiro.Workflow"). 'recordStepTx' upserts a row;-'loadStepIndex' reads an instance's recorded steps; 'stepExists' checks for-one step; 'findUnfinishedWorkflowIds' discovers resumable rows from-@keiro_workflows@ — the seam EP-42's resume worker builds on.--Callers normally use the re-exports from "Keiro.Workflow" rather than this-module directly.--}-module Keiro.Workflow.Schema (-    -- * Rows+-- | The @keiro_workflow_steps@ table: the derived index of journaled+-- workflow steps.+--+-- The journal stream (@wf:\<name\>-\<id\>@) is the source of truth for replay;+-- this table is a fast-lookup view kept in sync inside the same transaction as+-- each journal append (see "Keiro.Workflow"). 'recordStepTx' upserts a row;+-- 'loadStepIndex' reads an instance's recorded steps; 'stepExists' checks for+-- one step; 'findUnfinishedWorkflowIds' discovers resumable rows from+-- @keiro_workflows@ — the seam EP-42's resume worker builds on.+--+-- Callers normally use the re-exports from "Keiro.Workflow" rather than this+-- module directly.+module Keiro.Workflow.Schema+  ( -- * Rows     WorkflowStepRow (..),      -- * Storage@@ -29,7 +28,7 @@     stepExists,     currentGeneration,     findUnfinishedWorkflowIds,-)+  ) where  import Contravariant.Extras (contrazip2, contrazip3, contrazip4, contrazip6)@@ -46,221 +45,213 @@ import Kiroku.Store.Transaction (runTransaction) import "hasql-transaction" Hasql.Transaction qualified as Tx -{- | A row of the @keiro_workflow_steps@ index: the workflow instance and-name, the step name, the step's JSON result, and when it was recorded. The-terminal completion marker is stored as a row whose 'stepName' is-'Keiro.Workflow.Types.completedStepName' and whose 'result' is JSON @null@.--}+-- | A row of the @keiro_workflow_steps@ index: the workflow instance and+-- name, the step name, the step's JSON result, and when it was recorded. The+-- terminal completion marker is stored as a row whose 'stepName' is+-- 'Keiro.Workflow.Types.completedStepName' and whose 'result' is JSON @null@. data WorkflowStepRow = WorkflowStepRow-    { workflowId :: !Text-    , workflowName :: !Text-    , generation :: !Int-    {- ^ EP-48: the journal /generation/ this step belongs to. Generation 0 is-    the pre-rotation default; @continueAsNew@ rotates onto higher generations.-    -}-    , stepName :: !Text-    , result :: !Value-    , recordedAt :: !UTCTime-    }-    deriving stock (Generic, Eq, Show)+  { workflowId :: !Text,+    workflowName :: !Text,+    -- | EP-48: the journal /generation/ this step belongs to. Generation 0 is+    --     the pre-rotation default; @continueAsNew@ rotates onto higher generations.+    generation :: !Int,+    stepName :: !Text,+    result :: !Value,+    recordedAt :: !UTCTime+  }+  deriving stock (Generic, Eq, Show) -{- | Upsert a step row inside the caller's transaction — an-@INSERT ... ON CONFLICT (workflow_id, step_name) DO NOTHING@, so a replayed-or raced write is a no-op. Called in the same transaction as the journal-append so the index and the journal stay consistent.--}+-- | Upsert a step row inside the caller's transaction — an+-- @INSERT ... ON CONFLICT (workflow_id, step_name) DO NOTHING@, so a replayed+-- or raced write is a no-op. Called in the same transaction as the journal+-- append so the index and the journal stay consistent. recordStepTx :: WorkflowStepRow -> Tx.Transaction () recordStepTx row =-    Tx.statement-        ( row ^. #workflowId-        , row ^. #workflowName-        , fromIntegral (row ^. #generation) :: Int32-        , row ^. #stepName-        , row ^. #result-        , row ^. #recordedAt-        )-        recordStepStmt+  Tx.statement+    ( row ^. #workflowId,+      row ^. #workflowName,+      fromIntegral (row ^. #generation) :: Int32,+      row ^. #stepName,+      row ^. #result,+      row ^. #recordedAt+    )+    recordStepStmt  lookupStepResultTx :: Text -> Text -> Int -> Text -> Tx.Transaction (Maybe Value) lookupStepResultTx wid name gen key =-    Tx.statement (wid, name, fromIntegral gen :: Int32, key) lookupStepResultStmt+  Tx.statement (wid, name, fromIntegral gen :: Int32, key) lookupStepResultStmt  lockWorkflowStepTx :: Text -> Tx.Transaction () lockWorkflowStepTx key =-    void (Tx.statement key lockWorkflowStepStmt)+  void (Tx.statement key lockWorkflowStepStmt)  deleteStepRowTx :: Text -> Text -> Int -> Text -> Tx.Transaction () deleteStepRowTx wid name gen key =-    Tx.statement-        (wid, name, fromIntegral gen :: Int32, key)-        deleteStepRowStmt+  Tx.statement+    (wid, name, fromIntegral gen :: Int32, key)+    deleteStepRowStmt  setWorkflowWakeAfterTx :: WorkflowName -> WorkflowId -> UTCTime -> Tx.Transaction () setWorkflowWakeAfterTx (WorkflowName name) (WorkflowId wid) wakeAfter =-    Tx.statement (wid, name, wakeAfter) setWorkflowWakeAfterStmt+  Tx.statement (wid, name, wakeAfter) setWorkflowWakeAfterStmt  clearWorkflowWakeAfterTx :: WorkflowName -> WorkflowId -> Tx.Transaction () clearWorkflowWakeAfterTx (WorkflowName name) (WorkflowId wid) =-    Tx.statement (wid, name) clearWorkflowWakeAfterStmt+  Tx.statement (wid, name) clearWorkflowWakeAfterStmt -{- | Load every recorded step for a workflow instance as a @step name ->-result@ map (includes the terminal completion marker row if present). Exposed-for EP-42's resume worker; the replay handler in "Keiro.Workflow" pre-loads-from the journal stream instead.--}+-- | Load every recorded step for a workflow instance as a @step name ->+-- result@ map (includes the terminal completion marker row if present). Exposed+-- for EP-42's resume worker; the replay handler in "Keiro.Workflow" pre-loads+-- from the journal stream instead. loadStepIndex :: (Store :> es) => WorkflowName -> WorkflowId -> Int -> Eff es (Map Text Value) loadStepIndex (WorkflowName name) (WorkflowId wid) gen =-    Map.fromList <$> runTransaction (Tx.statement (wid, name, fromIntegral gen :: Int32) loadStepIndexStmt)+  Map.fromList <$> runTransaction (Tx.statement (wid, name, fromIntegral gen :: Int32) loadStepIndexStmt) -{- | Point-lookup one recorded step result for a workflow instance and-generation, directly from the authoritative @keiro_workflow_steps@ index.-Used by the replay handler's @Await@ miss path as the safety net for a stale-in-memory map: the index is written in the same transaction as every journal-append, so it is complete even when the snapshot-seeded map is not.--}+-- | Point-lookup one recorded step result for a workflow instance and+-- generation, directly from the authoritative @keiro_workflow_steps@ index.+-- Used by the replay handler's @Await@ miss path as the safety net for a stale+-- in-memory map: the index is written in the same transaction as every journal+-- append, so it is complete even when the snapshot-seeded map is not. lookupStepResult :: (Store :> es) => WorkflowName -> WorkflowId -> Int -> Text -> Eff es (Maybe Value) lookupStepResult (WorkflowName name) (WorkflowId wid) gen key =-    runTransaction (Tx.statement (wid, name, fromIntegral gen :: Int32, key) lookupStepResultStmt)+  runTransaction (Tx.statement (wid, name, fromIntegral gen :: Int32, key) lookupStepResultStmt) -{- | Whether a workflow instance already has an index row for the given step-name. Used to make journal re-appends idempotent without relying on the event-store's duplicate-id rejection.--}+-- | Whether a workflow instance already has an index row for the given step+-- name. Used to make journal re-appends idempotent without relying on the event+-- store's duplicate-id rejection. stepExists :: (Store :> es) => WorkflowName -> WorkflowId -> Int -> Text -> Eff es Bool stepExists (WorkflowName name) (WorkflowId wid) gen key =-    runTransaction (Tx.statement (wid, name, fromIntegral gen :: Int32, key) stepExistsStmt)+  runTransaction (Tx.statement (wid, name, fromIntegral gen :: Int32, key) stepExistsStmt) -{- | The current (highest) generation recorded for a logical workflow, or 0 if-it has no step rows yet (EP-48). Index-supported by the-@(workflow_id, workflow_name, generation)@ lookup index. A workflow that never-rotates stays at generation 0 and behaves byte-for-byte as it did before EP-48.-A rotation commits the next generation's seed step under generation @g+1@ in-the same logical-id key space, so @MAX(generation)@ is unambiguously the-current generation.--}+-- | The current (highest) generation recorded for a logical workflow, or 0 if+-- it has no step rows yet (EP-48). Index-supported by the+-- @(workflow_id, workflow_name, generation)@ lookup index. A workflow that never+-- rotates stays at generation 0 and behaves byte-for-byte as it did before EP-48.+-- A rotation commits the next generation's seed step under generation @g+1@ in+-- the same logical-id key space, so @MAX(generation)@ is unambiguously the+-- current generation. currentGeneration :: (Store :> es) => WorkflowName -> WorkflowId -> Eff es Int currentGeneration (WorkflowName name) (WorkflowId wid) =-    fromIntegral <$> runTransaction (Tx.statement (wid, name) currentGenerationStmt)+  fromIntegral <$> runTransaction (Tx.statement (wid, name) currentGenerationStmt) -{- | Return the @(workflow_id, workflow_name)@ of every non-terminal workflow-instance. Terminal statuses are @completed@, @cancelled@, and @failed@, matching-'Keiro.Workflow.Instance.WorkflowStatus'. The explicit time parameter is-reserved for wake-time filtering; today it keeps the call shape stable for that-addition.--}+-- | Return the @(workflow_id, workflow_name)@ of every non-terminal workflow+-- instance. Terminal statuses are @completed@, @cancelled@, and @failed@, matching+-- 'Keiro.Workflow.Instance.WorkflowStatus'. The explicit time parameter is+-- reserved for wake-time filtering; today it keeps the call shape stable for that+-- addition. findUnfinishedWorkflowIds :: (Store :> es) => UTCTime -> Eff es [(Text, Text)] findUnfinishedWorkflowIds now =-    runTransaction (Tx.statement now findUnfinishedWorkflowIdsStmt)+  runTransaction (Tx.statement now findUnfinishedWorkflowIdsStmt)  recordStepStmt :: Statement (Text, Text, Int32, Text, Value, UTCTime) () recordStepStmt =-    preparable-        """-        INSERT INTO keiro.keiro_workflow_steps-          (workflow_id, workflow_name, generation, step_name, result, recorded_at)-        VALUES ($1, $2, $3, $4, $5, $6)-        ON CONFLICT (workflow_id, workflow_name, generation, step_name) DO NOTHING-        """-        ( contrazip6-            (E.param (E.nonNullable E.text))-            (E.param (E.nonNullable E.text))-            (E.param (E.nonNullable E.int4))-            (E.param (E.nonNullable E.text))-            (E.param (E.nonNullable E.jsonb))-            (E.param (E.nonNullable E.timestamptz))-        )-        D.noResult+  preparable+    """+    INSERT INTO keiro.keiro_workflow_steps+      (workflow_id, workflow_name, generation, step_name, result, recorded_at)+    VALUES ($1, $2, $3, $4, $5, $6)+    ON CONFLICT (workflow_id, workflow_name, generation, step_name) DO NOTHING+    """+    ( contrazip6+        (E.param (E.nonNullable E.text))+        (E.param (E.nonNullable E.text))+        (E.param (E.nonNullable E.int4))+        (E.param (E.nonNullable E.text))+        (E.param (E.nonNullable E.jsonb))+        (E.param (E.nonNullable E.timestamptz))+    )+    D.noResult  lookupStepResultStmt :: Statement (Text, Text, Int32, Text) (Maybe Value) lookupStepResultStmt =-    preparable-        """-        SELECT result-        FROM keiro.keiro_workflow_steps-        WHERE workflow_id = $1 AND workflow_name = $2 AND generation = $3 AND step_name = $4-        """-        ( contrazip4-            (E.param (E.nonNullable E.text))-            (E.param (E.nonNullable E.text))-            (E.param (E.nonNullable E.int4))-            (E.param (E.nonNullable E.text))-        )-        (D.rowMaybe (D.column (D.nonNullable D.jsonb)))+  preparable+    """+    SELECT result+    FROM keiro.keiro_workflow_steps+    WHERE workflow_id = $1 AND workflow_name = $2 AND generation = $3 AND step_name = $4+    """+    ( contrazip4+        (E.param (E.nonNullable E.text))+        (E.param (E.nonNullable E.text))+        (E.param (E.nonNullable E.int4))+        (E.param (E.nonNullable E.text))+    )+    (D.rowMaybe (D.column (D.nonNullable D.jsonb)))  lockWorkflowStepStmt :: Statement Text Int32 lockWorkflowStepStmt =-    preparable-        """-        SELECT 1::int4 FROM pg_advisory_xact_lock(hashtextextended($1, 0))-        """-        (E.param (E.nonNullable E.text))-        (D.singleRow (D.column (D.nonNullable D.int4)))+  preparable+    """+    SELECT 1::int4 FROM pg_advisory_xact_lock(hashtextextended($1, 0))+    """+    (E.param (E.nonNullable E.text))+    (D.singleRow (D.column (D.nonNullable D.int4)))  deleteStepRowStmt :: Statement (Text, Text, Int32, Text) () deleteStepRowStmt =-    preparable-        """-        DELETE FROM keiro.keiro_workflow_steps-        WHERE workflow_id = $1-          AND workflow_name = $2-          AND generation = $3-          AND step_name = $4-        """-        ( contrazip4-            (E.param (E.nonNullable E.text))-            (E.param (E.nonNullable E.text))-            (E.param (E.nonNullable E.int4))-            (E.param (E.nonNullable E.text))-        )-        D.noResult+  preparable+    """+    DELETE FROM keiro.keiro_workflow_steps+    WHERE workflow_id = $1+      AND workflow_name = $2+      AND generation = $3+      AND step_name = $4+    """+    ( contrazip4+        (E.param (E.nonNullable E.text))+        (E.param (E.nonNullable E.text))+        (E.param (E.nonNullable E.int4))+        (E.param (E.nonNullable E.text))+    )+    D.noResult  loadStepIndexStmt :: Statement (Text, Text, Int32) [(Text, Value)] loadStepIndexStmt =-    preparable-        """-        SELECT step_name, result-        FROM keiro.keiro_workflow_steps-        WHERE workflow_id = $1 AND workflow_name = $2 AND generation = $3-        """-        ( contrazip3-            (E.param (E.nonNullable E.text))-            (E.param (E.nonNullable E.text))-            (E.param (E.nonNullable E.int4))-        )-        (D.rowList ((,) <$> D.column (D.nonNullable D.text) <*> D.column (D.nonNullable D.jsonb)))+  preparable+    """+    SELECT step_name, result+    FROM keiro.keiro_workflow_steps+    WHERE workflow_id = $1 AND workflow_name = $2 AND generation = $3+    """+    ( contrazip3+        (E.param (E.nonNullable E.text))+        (E.param (E.nonNullable E.text))+        (E.param (E.nonNullable E.int4))+    )+    (D.rowList ((,) <$> D.column (D.nonNullable D.text) <*> D.column (D.nonNullable D.jsonb)))  stepExistsStmt :: Statement (Text, Text, Int32, Text) Bool stepExistsStmt =-    preparable-        """-        SELECT EXISTS (-          SELECT 1 FROM keiro.keiro_workflow_steps-          WHERE workflow_id = $1 AND workflow_name = $2 AND generation = $3 AND step_name = $4-        )-        """-        ( contrazip4-            (E.param (E.nonNullable E.text))-            (E.param (E.nonNullable E.text))-            (E.param (E.nonNullable E.int4))-            (E.param (E.nonNullable E.text))-        )-        (D.singleRow (D.column (D.nonNullable D.bool)))+  preparable+    """+    SELECT EXISTS (+      SELECT 1 FROM keiro.keiro_workflow_steps+      WHERE workflow_id = $1 AND workflow_name = $2 AND generation = $3 AND step_name = $4+    )+    """+    ( contrazip4+        (E.param (E.nonNullable E.text))+        (E.param (E.nonNullable E.text))+        (E.param (E.nonNullable E.int4))+        (E.param (E.nonNullable E.text))+    )+    (D.singleRow (D.column (D.nonNullable D.bool)))  -- The current generation is MAX(generation) for the logical id+name, or 0 when -- the workflow has no rows. Index-supported by keiro_workflow_steps_workflow_idx. currentGenerationStmt :: Statement (Text, Text) Int32 currentGenerationStmt =-    preparable-        """-        SELECT COALESCE(MAX(generation), 0)::int4-        FROM keiro.keiro_workflow_steps-        WHERE workflow_id = $1 AND workflow_name = $2-        """-        ( contrazip2-            (E.param (E.nonNullable E.text))-            (E.param (E.nonNullable E.text))-        )-        (D.singleRow (D.column (D.nonNullable D.int4)))+  preparable+    """+    SELECT COALESCE(MAX(generation), 0)::int4+    FROM keiro.keiro_workflow_steps+    WHERE workflow_id = $1 AND workflow_name = $2+    """+    ( contrazip2+        (E.param (E.nonNullable E.text))+        (E.param (E.nonNullable E.text))+    )+    (D.singleRow (D.column (D.nonNullable D.int4)))  -- The terminal-status literals must match 'Keiro.Workflow.Instance.statusToText' -- for completed, cancelled, and failed. The timestamp parameter makes@@ -268,44 +259,44 @@ -- until their timer is due. findUnfinishedWorkflowIdsStmt :: Statement UTCTime [(Text, Text)] findUnfinishedWorkflowIdsStmt =-    preparable-        """-        SELECT workflow_id, workflow_name-        FROM keiro.keiro_workflows-        WHERE status NOT IN ('completed', 'cancelled', 'failed')-          AND (wake_after IS NULL OR wake_after <= $1)-        ORDER BY workflow_name, workflow_id-        """-        (E.param (E.nonNullable E.timestamptz))-        (D.rowList ((,) <$> D.column (D.nonNullable D.text) <*> D.column (D.nonNullable D.text)))+  preparable+    """+    SELECT workflow_id, workflow_name+    FROM keiro.keiro_workflows+    WHERE status NOT IN ('completed', 'cancelled', 'failed')+      AND (wake_after IS NULL OR wake_after <= $1)+    ORDER BY workflow_name, workflow_id+    """+    (E.param (E.nonNullable E.timestamptz))+    (D.rowList ((,) <$> D.column (D.nonNullable D.text) <*> D.column (D.nonNullable D.text)))  setWorkflowWakeAfterStmt :: Statement (Text, Text, UTCTime) () setWorkflowWakeAfterStmt =-    preparable-        """-        UPDATE keiro.keiro_workflows-        SET wake_after = $3,-            updated_at = now()-        WHERE workflow_id = $1 AND workflow_name = $2-        """-        ( contrazip3-            (E.param (E.nonNullable E.text))-            (E.param (E.nonNullable E.text))-            (E.param (E.nonNullable E.timestamptz))-        )-        D.noResult+  preparable+    """+    UPDATE keiro.keiro_workflows+    SET wake_after = $3,+        updated_at = now()+    WHERE workflow_id = $1 AND workflow_name = $2+    """+    ( contrazip3+        (E.param (E.nonNullable E.text))+        (E.param (E.nonNullable E.text))+        (E.param (E.nonNullable E.timestamptz))+    )+    D.noResult  clearWorkflowWakeAfterStmt :: Statement (Text, Text) () clearWorkflowWakeAfterStmt =-    preparable-        """-        UPDATE keiro.keiro_workflows-        SET wake_after = NULL,-            updated_at = now()-        WHERE workflow_id = $1 AND workflow_name = $2-        """-        ( contrazip2-            (E.param (E.nonNullable E.text))-            (E.param (E.nonNullable E.text))-        )-        D.noResult+  preparable+    """+    UPDATE keiro.keiro_workflows+    SET wake_after = NULL,+        updated_at = now()+    WHERE workflow_id = $1 AND workflow_name = $2+    """+    ( contrazip2+        (E.param (E.nonNullable E.text))+        (E.param (E.nonNullable E.text))+    )+    D.noResult
src/Keiro/Workflow/Sleep.hs view
@@ -1,81 +1,80 @@-{- | Durable @sleep@ for workflows, backed by the existing @keiro_timers@ table.--== What this gives you--A workflow author can insert a durable pause between steps:--@-demo :: ('Workflow' ':>' es, 'Store' ':>' es, IOE ':>' es) => Eff es (Int, Int)-demo = do-  a <- 'step' (StepName \"a\") (liftIO incr)   -- side effect #1-  'sleepNamed' (StepName \"cool\") 300          -- durable wait, survives a restart-  b <- 'step' (StepName \"b\") (liftIO incr)   -- side effect #2-  pure (a, b)-@--On the __first__ run, @demo@ executes @a@, journals it, arms a Postgres timer-for the sleep, and __suspends__ — 'Keiro.Workflow.runWorkflow' returns-'Suspended' and the journal @wf:demo-\<id\>@ holds only the @StepRecorded \"a\"@-event. The @b@ side effect has not run. The process can now crash, be-redeployed, or sit idle for the full delay: the only durable state of the pause-is a single row in 'keiro_timers', so the wait survives a restart with __no-external scheduler and no in-memory timer thread__.--When the timer becomes due, the existing timer worker-('Keiro.Timer.runTimerWorker') fires it through 'workflowSleepFireAction',-which recognises the row as a workflow sleep (by the JSON payload-discriminator), reconstructs the journal stream, and appends a-@StepRecorded \"sleep:cool\"@ completion. A later run replays: @step \"a\"@-short-circuits to its recorded result, @sleepNamed \"cool\"@ sees its completion-already journaled and returns immediately, and only @step \"b\"@ runs for real.--== 'sleepNamed' vs. 'sleep'--* 'sleepNamed' is the __stable primitive__. Replay matches the sleep on its-  (prefixed) 'StepName', so the name must be deterministic across replays. A-  user-supplied name is unconditionally stable: the same source always produces-  the same name regardless of how surrounding code is reordered between deploys.--* 'sleep' is an ordinal convenience built on 'sleepNamed' via-  'Keiro.Workflow.freshOrdinal' (the @N@th sleep in a run gets @sleep:N@). Its-  determinism is __conditional__: reordering or inserting sleeps between deploys-  shifts the ordinals and can make a resumed in-flight workflow re-arm a-  /different/ timer. Prefer 'sleepNamed' for anything that must survive a code-  change mid-flight.--== Operational contract--* __Payload discriminator.__ A workflow-sleep timer row carries-  @{\"kind\":\"keiro.workflow.sleep\",\"step\":\"sleep:\<suffix\>\",\"gen\":0}@-  in its @payload@ (see 'sleepTimerPayload' / 'parseSleepPayload'). This is how-  a single timer worker distinguishes workflow sleeps from ordinary-  process-manager timers, routes each correctly, and pins a fire to the-  generation that armed it. Legacy payloads without @gen@ remain supported.--* __Deterministic timer id.__ The timer id is a v5 UUID over-  @(\"keiro\":\"workflow-sleep\":name:id:generation:sleepStepName)@ for-  generation 1 and later, while generation 0 keeps the legacy-  @(\"keiro\":\"workflow-sleep\":name:id:sleepStepName)@ shape. The workflow-  sleep arm uses 'Keiro.Timer.scheduleTimerOnceTx', so the first arm's-  @fire_at@ wins and every resume that re-enters the not-yet-resolved sleep-  leaves the row untouched. The sleep duration is measured from the first arm,-  not from the latest resume pass.--* __No @keiro_timers@ schema change.__ Routing is entirely a function of the-  caller-supplied fire action and the JSON payload; this module owns no-  migration.--* __A worker must drain the timers.__ A sleep only ever fires if some timer-  worker runs 'workflowSleepFireAction' (via 'runWorkflowTimerWorker', or by-  passing 'workflowSleepFireAction' directly to 'Keiro.Timer.runTimerWorker').-  A sleep whose timer is never drained — or one whose timer an operator-  'Keiro.Timer.cancelTimer's — stays suspended forever until an operator-  intervenes. Workflow sleeps otherwise inherit the timer subsystem's recovery-  surface ('Keiro.Timer.findStuckTimers' / 'Keiro.Timer.requeueStuckTimer' /-  'Keiro.Timer.deadLetterTimer') for free.--}-module Keiro.Workflow.Sleep (-    -- * Authoring surface+-- | Durable @sleep@ for workflows, backed by the existing @keiro_timers@ table.+--+-- == What this gives you+--+-- A workflow author can insert a durable pause between steps:+--+-- @+-- demo :: ('Workflow' ':>' es, 'Store' ':>' es, IOE ':>' es) => Eff es (Int, Int)+-- demo = do+--   a <- 'step' (StepName \"a\") (liftIO incr)   -- side effect #1+--   'sleepNamed' (StepName \"cool\") 300          -- durable wait, survives a restart+--   b <- 'step' (StepName \"b\") (liftIO incr)   -- side effect #2+--   pure (a, b)+-- @+--+-- On the __first__ run, @demo@ executes @a@, journals it, arms a Postgres timer+-- for the sleep, and __suspends__ — 'Keiro.Workflow.runWorkflow' returns+-- 'Suspended' and the journal @wf:demo-\<id\>@ holds only the @StepRecorded \"a\"@+-- event. The @b@ side effect has not run. The process can now crash, be+-- redeployed, or sit idle for the full delay: the only durable state of the pause+-- is a single row in 'keiro_timers', so the wait survives a restart with __no+-- external scheduler and no in-memory timer thread__.+--+-- When the timer becomes due, the existing timer worker+-- ('Keiro.Timer.runTimerWorker') fires it through 'workflowSleepFireAction',+-- which recognises the row as a workflow sleep (by the JSON payload+-- discriminator), reconstructs the journal stream, and appends a+-- @StepRecorded \"sleep:cool\"@ completion. A later run replays: @step \"a\"@+-- short-circuits to its recorded result, @sleepNamed \"cool\"@ sees its completion+-- already journaled and returns immediately, and only @step \"b\"@ runs for real.+--+-- == 'sleepNamed' vs. 'sleep'+--+-- * 'sleepNamed' is the __stable primitive__. Replay matches the sleep on its+--   (prefixed) 'StepName', so the name must be deterministic across replays. A+--   user-supplied name is unconditionally stable: the same source always produces+--   the same name regardless of how surrounding code is reordered between deploys.+--+-- * 'sleep' is an ordinal convenience built on 'sleepNamed' via+--   'Keiro.Workflow.freshOrdinal' (the @N@th sleep in a run gets @sleep:N@). Its+--   determinism is __conditional__: reordering or inserting sleeps between deploys+--   shifts the ordinals and can make a resumed in-flight workflow re-arm a+--   /different/ timer. Prefer 'sleepNamed' for anything that must survive a code+--   change mid-flight.+--+-- == Operational contract+--+-- * __Payload discriminator.__ A workflow-sleep timer row carries+--   @{\"kind\":\"keiro.workflow.sleep\",\"step\":\"sleep:\<suffix\>\",\"gen\":0}@+--   in its @payload@ (see 'sleepTimerPayload' / 'parseSleepPayload'). This is how+--   a single timer worker distinguishes workflow sleeps from ordinary+--   process-manager timers, routes each correctly, and pins a fire to the+--   generation that armed it. Legacy payloads without @gen@ remain supported.+--+-- * __Deterministic timer id.__ The timer id is a v5 UUID over+--   @(\"keiro\":\"workflow-sleep\":name:id:generation:sleepStepName)@ for+--   generation 1 and later, while generation 0 keeps the legacy+--   @(\"keiro\":\"workflow-sleep\":name:id:sleepStepName)@ shape. The workflow+--   sleep arm uses 'Keiro.Timer.scheduleTimerOnceTx', so the first arm's+--   @fire_at@ wins and every resume that re-enters the not-yet-resolved sleep+--   leaves the row untouched. The sleep duration is measured from the first arm,+--   not from the latest resume pass.+--+-- * __No @keiro_timers@ schema change.__ Routing is entirely a function of the+--   caller-supplied fire action and the JSON payload; this module owns no+--   migration.+--+-- * __A worker must drain the timers.__ A sleep only ever fires if some timer+--   worker runs 'workflowSleepFireAction' (via 'runWorkflowTimerWorker', or by+--   passing 'workflowSleepFireAction' directly to 'Keiro.Timer.runTimerWorker').+--   A sleep whose timer is never drained — or one whose timer an operator+--   'Keiro.Timer.cancelTimer's — stays suspended forever until an operator+--   intervenes. Workflow sleeps otherwise inherit the timer subsystem's recovery+--   surface ('Keiro.Timer.findStuckTimers' / 'Keiro.Timer.requeueStuckTimer' /+--   'Keiro.Timer.deadLetterTimer') for free.+module Keiro.Workflow.Sleep+  ( -- * Authoring surface     sleepNamed,     sleep, @@ -90,7 +89,7 @@     parseSleepPayload,     matchSleepTimerGeneration,     workflowSleepKind,-)+  ) where  import Data.Aeson (Value (..), object)@@ -104,16 +103,16 @@ import Effectful.Exception (throwIO) import Keiro.Prelude import Keiro.Telemetry (KeiroMetrics)-import Keiro.Timer (-    TimerId (..),+import Keiro.Timer+  ( TimerId (..),     TimerRequest (..),     TimerRow,     cancelTimer,     runTimerWorker,     scheduleTimerOnceTx,- )-import Keiro.Workflow (-    JournalAppendOutcome (..),+  )+import Keiro.Workflow+  ( JournalAppendOutcome (..),     StepName (..),     Workflow,     WorkflowError (..),@@ -130,7 +129,7 @@     prepareJournalAppend,     setWorkflowWakeAfterTx,     sleepStepPrefix,- )+  ) import Keiro.Workflow.Instance qualified as Instance import Kiroku.Store.Effect (Store) import Kiroku.Store.Transaction (runTransaction)@@ -140,106 +139,100 @@ -- Discriminator and payload -- --------------------------------------------------------------------------- -{- | The payload @"kind"@ tag that marks a 'keiro_timers' row as a workflow-sleep, distinguishing it from an ordinary process-manager timer so a single-timer worker can route each correctly.--}+-- | The payload @"kind"@ tag that marks a 'keiro_timers' row as a workflow+-- sleep, distinguishing it from an ordinary process-manager timer so a single+-- timer worker can route each correctly. workflowSleepKind :: Text workflowSleepKind = "keiro.workflow.sleep" -{- | Build the JSON payload carried on a workflow-sleep timer row. The first-argument is the generation that armed the timer; the second is the full-@"sleep:\<suffix\>"@ journal step name the firing will record.--}+-- | Build the JSON payload carried on a workflow-sleep timer row. The first+-- argument is the generation that armed the timer; the second is the full+-- @"sleep:\<suffix\>"@ journal step name the firing will record. sleepTimerPayload :: Int -> Text -> Value sleepTimerPayload gen fullStep =-    object-        [ "kind" Aeson..= workflowSleepKind-        , "step" Aeson..= fullStep-        , "gen" Aeson..= gen-        ]+  object+    [ "kind" Aeson..= workflowSleepKind,+      "step" Aeson..= fullStep,+      "gen" Aeson..= gen+    ] -{- | Recognise and extract a workflow-sleep payload. The result contains the-full step name and the generation when the payload records one. 'Nothing' in-the generation slot denotes a legacy workflow-sleep payload written before-generation pinning; an overall 'Nothing' denotes any other timer (for example,-a process manager's).--}+-- | Recognise and extract a workflow-sleep payload. The result contains the+-- full step name and the generation when the payload records one. 'Nothing' in+-- the generation slot denotes a legacy workflow-sleep payload written before+-- generation pinning; an overall 'Nothing' denotes any other timer (for example,+-- a process manager's). parseSleepPayload :: Value -> Maybe (Text, Maybe Int) parseSleepPayload = \case-    Object o-        | KeyMap.lookup "kind" o == Just (String workflowSleepKind) ->-            case KeyMap.lookup "step" o of-                Just (String s) ->-                    case KeyMap.lookup "gen" o of-                        Nothing -> Just (s, Nothing)-                        Just value ->-                            case Aeson.fromJSON value of-                                Aeson.Success gen -> Just (s, Just gen)-                                Aeson.Error{} -> Nothing-                _ -> Nothing-    _ -> Nothing+  Object o+    | KeyMap.lookup "kind" o == Just (String workflowSleepKind) ->+        case KeyMap.lookup "step" o of+          Just (String s) ->+            case KeyMap.lookup "gen" o of+              Nothing -> Just (s, Nothing)+              Just value ->+                case Aeson.fromJSON value of+                  Aeson.Success gen -> Just (s, Just gen)+                  Aeson.Error {} -> Nothing+          _ -> Nothing+  _ -> Nothing  -- --------------------------------------------------------------------------- -- Deterministic ids and step names -- --------------------------------------------------------------------------- -{- | The deterministic timer id for a sleep. Generation 0 keeps the legacy v5-UUID over @(\"keiro\":\"workflow-sleep\":name:id:fullStep)@ so in-flight-pre-change timers remain signalable. Generations 1 and later include the-generation component so a sleep after 'Keiro.Workflow.continueAsNew' never-collides with a prior generation's terminal timer row.--}+-- | The deterministic timer id for a sleep. Generation 0 keeps the legacy v5+-- UUID over @(\"keiro\":\"workflow-sleep\":name:id:fullStep)@ so in-flight+-- pre-change timers remain signalable. Generations 1 and later include the+-- generation component so a sleep after 'Keiro.Workflow.continueAsNew' never+-- collides with a prior generation's terminal timer row. sleepTimerId :: WorkflowName -> WorkflowId -> Int -> Text -> TimerId sleepTimerId name wid gen fullStep =-    TimerId $-        UUID.V5.generateNamed UUID.V5.namespaceURL $-            fmap (fromIntegral . fromEnum) $-                Text.unpack $-                    Text.intercalate-                        ":"-                        components+  TimerId $+    UUID.V5.generateNamed UUID.V5.namespaceURL $+      fmap (fromIntegral . fromEnum) $+        Text.unpack $+          Text.intercalate+            ":"+            components   where     components-        | gen <= 0 =-            [ "keiro"-            , "workflow-sleep"-            , unWorkflowName name-            , unWorkflowId wid-            , fullStep-            ]-        | otherwise =-            [ "keiro"-            , "workflow-sleep"-            , unWorkflowName name-            , unWorkflowId wid-            , Text.pack (show gen)-            , fullStep-            ]+      | gen <= 0 =+          [ "keiro",+            "workflow-sleep",+            unWorkflowName name,+            unWorkflowId wid,+            fullStep+          ]+      | otherwise =+          [ "keiro",+            "workflow-sleep",+            unWorkflowName name,+            unWorkflowId wid,+            Text.pack (show gen),+            fullStep+          ] -{- | Recover the generation represented by a deterministic workflow-sleep-timer id. Candidate generations from @currentGen@ down to zero are tested-against 'sleepTimerId'; this lets a new worker pin legacy payloads that do not-carry an explicit generation. Returns 'Nothing' only for an operator-crafted-or otherwise non-matching timer id.--}+-- | Recover the generation represented by a deterministic workflow-sleep+-- timer id. Candidate generations from @currentGen@ down to zero are tested+-- against 'sleepTimerId'; this lets a new worker pin legacy payloads that do not+-- carry an explicit generation. Returns 'Nothing' only for an operator-crafted+-- or otherwise non-matching timer id. matchSleepTimerGeneration ::-    WorkflowName ->-    WorkflowId ->-    Int ->-    Text ->-    TimerId ->-    Maybe Int+  WorkflowName ->+  WorkflowId ->+  Int ->+  Text ->+  TimerId ->+  Maybe Int matchSleepTimerGeneration name wid currentGen fullStep timerId =-    find-        (\gen -> sleepTimerId name wid gen fullStep == timerId)-        (reverse [0 .. max 0 currentGen])+  find+    (\gen -> sleepTimerId name wid gen fullStep == timerId)+    (reverse [0 .. max 0 currentGen]) -{- | The durable journal step name for a sleep: the user's suffix prefixed with-'sleepStepPrefix'. @'sleepStepName' (StepName \"cool\") == \"sleep:cool\"@. The-prefix keeps the journal self-describing — an operator scanning it sees-@sleep:@ and knows the entry is a durable wait, not an ordinary step.--}+-- | The durable journal step name for a sleep: the user's suffix prefixed with+-- 'sleepStepPrefix'. @'sleepStepName' (StepName \"cool\") == \"sleep:cool\"@. The+-- prefix keeps the journal self-describing — an operator scanning it sees+-- @sleep:@ and knows the entry is a durable wait, not an ordinary step. sleepStepName :: StepName -> Text sleepStepName (StepName suffix) = sleepStepPrefix <> suffix @@ -247,139 +240,134 @@ -- Authoring surface -- --------------------------------------------------------------------------- -{- | 'awaitStep' specialised to a 'Value' result. The recorded sleep completion-carries JSON @null@; 'Value''s 'FromJSON' is the identity, so any recorded-result decodes, which decouples the sleep from a @FromJSON ()@ instance.--}+-- | 'awaitStep' specialised to a 'Value' result. The recorded sleep completion+-- carries JSON @null@; 'Value''s 'FromJSON' is the identity, so any recorded+-- result decodes, which decouples the sleep from a @FromJSON ()@ instance. awaitValue :: (Workflow :> es) => StepName -> Eff es () -> Eff es Value awaitValue = awaitStep -{- | Durably pause the workflow for @delta@ under the stable name @userStep@.-On the first encounter this arms a deterministic 'keiro_timers' row and-suspends the run; the suspension resolves when a timer worker fires the row-(see 'workflowSleepFireAction') and journals the sleep's completion, after which-a later run replays past the sleep without re-arming.--The arming action is idempotent (a resumed workflow re-runs it until the sleep-resolves): it inserts with a deterministic 'sleepTimerId' only when the row is-absent, so the first @fire_at@ persists across every resume pass.--}+-- | Durably pause the workflow for @delta@ under the stable name @userStep@.+-- On the first encounter this arms a deterministic 'keiro_timers' row and+-- suspends the run; the suspension resolves when a timer worker fires the row+-- (see 'workflowSleepFireAction') and journals the sleep's completion, after which+-- a later run replays past the sleep without re-arming.+--+-- The arming action is idempotent (a resumed workflow re-runs it until the sleep+-- resolves): it inserts with a deterministic 'sleepTimerId' only when the row is+-- absent, so the first @fire_at@ persists across every resume pass. sleepNamed ::-    (Workflow :> es, Store :> es, IOE :> es) =>-    StepName ->-    NominalDiffTime ->-    Eff es ()+  (Workflow :> es, Store :> es, IOE :> es) =>+  StepName ->+  NominalDiffTime ->+  Eff es () sleepNamed userStep delta = do-    (name, wid) <- currentWorkflow-    gen <- currentRunGeneration-    let full = sleepStepName userStep-        armedStep = StepName full-    void . awaitValue armedStep $ do-        now <- liftIO getCurrentTime-        let request =-                TimerRequest-                    { timerId = sleepTimerId name wid gen full-                    , processManagerName = unWorkflowName name-                    , correlationId = unWorkflowId wid-                    , fireAt = addUTCTime delta now-                    , payload = sleepTimerPayload gen full-                    }-        -- Only the arm that created the timer writes the wake hint. Replays-        -- leave both fire_at and wake_after untouched, so re-entering a due or-        -- already-fired sleep cannot postpone discovery. Firing clears the-        -- hint in the same transaction as its journal append.-        runTransaction $ do-            inserted <- scheduleTimerOnceTx request-            when inserted (setWorkflowWakeAfterTx name wid (request ^. #fireAt))+  (name, wid) <- currentWorkflow+  gen <- currentRunGeneration+  let full = sleepStepName userStep+      armedStep = StepName full+  void . awaitValue armedStep $ do+    now <- liftIO getCurrentTime+    let request =+          TimerRequest+            { timerId = sleepTimerId name wid gen full,+              processManagerName = unWorkflowName name,+              correlationId = unWorkflowId wid,+              fireAt = addUTCTime delta now,+              payload = sleepTimerPayload gen full+            }+    -- Only the arm that created the timer writes the wake hint. Replays+    -- leave both fire_at and wake_after untouched, so re-entering a due or+    -- already-fired sleep cannot postpone discovery. Firing clears the+    -- hint in the same transaction as its journal append.+    runTransaction $ do+      inserted <- scheduleTimerOnceTx request+      when inserted (setWorkflowWakeAfterTx name wid (request ^. #fireAt)) -{- | Durably pause the workflow for @delta@ under an ordinal name (the @N@th-sleep in a run becomes @sleep:N@). Convenient but its determinism is-conditional — see the module header. Prefer 'sleepNamed' for anything that must-survive a code change mid-flight.--}+-- | Durably pause the workflow for @delta@ under an ordinal name (the @N@th+-- sleep in a run becomes @sleep:N@). Convenient but its determinism is+-- conditional — see the module header. Prefer 'sleepNamed' for anything that must+-- survive a code change mid-flight. sleep :: (Workflow :> es, Store :> es, IOE :> es) => NominalDiffTime -> Eff es () sleep delta = do-    n <- freshOrdinal "sleep"-    sleepNamed (StepName (Text.pack (show n))) delta+  n <- freshOrdinal "sleep"+  sleepNamed (StepName (Text.pack (show n))) delta  -- --------------------------------------------------------------------------- -- Firing and worker wiring -- --------------------------------------------------------------------------- -{- | The fire action for workflow-sleep timers. For a 'TimerRow' whose payload-is a workflow-sleep discriminator, reconstruct the workflow identity from the-row's @processManagerName@ (= workflow name) and @correlationId@ (= workflow-id), resolve the generation that armed the timer, append a @StepRecorded@-completion (@result = null@) to that generation's journal, and return the-deterministic 'EventId' so the worker marks the timer @Fired@. Returns-'Nothing' for a row whose payload is __not__ a workflow sleep, or for a sleep-owned by a terminal workflow (whose timer is cancelled), so a mixed worker can-delegate that row to its process-manager fire action.--Idempotent: 'prepareJournalAppend' pre-checks the generation-scoped step and-the event id is deterministic, so at-least-once timer firing yields-exactly-once journaling even after the workflow has rotated.--}+-- | The fire action for workflow-sleep timers. For a 'TimerRow' whose payload+-- is a workflow-sleep discriminator, reconstruct the workflow identity from the+-- row's @processManagerName@ (= workflow name) and @correlationId@ (= workflow+-- id), resolve the generation that armed the timer, append a @StepRecorded@+-- completion (@result = null@) to that generation's journal, and return the+-- deterministic 'EventId' so the worker marks the timer @Fired@. Returns+-- 'Nothing' for a row whose payload is __not__ a workflow sleep, or for a sleep+-- owned by a terminal workflow (whose timer is cancelled), so a mixed worker can+-- delegate that row to its process-manager fire action.+--+-- Idempotent: 'prepareJournalAppend' pre-checks the generation-scoped step and+-- the event id is deterministic, so at-least-once timer firing yields+-- exactly-once journaling even after the workflow has rotated. workflowSleepFireAction ::-    (Store :> es, IOE :> es) => TimerRow -> Eff es (Maybe EventId)+  (Store :> es, IOE :> es) => TimerRow -> Eff es (Maybe EventId) workflowSleepFireAction row =-    case parseSleepPayload (row ^. #payload) of-        Nothing -> pure Nothing-        Just (full, payloadGen) -> do-            let name = WorkflowName (row ^. #processManagerName)-                wid = WorkflowId (row ^. #correlationId)-            Instance.lookupInstance name wid >>= \case-                Just instanceRow-                    | instanceRow ^. #status-                        `elem` [Instance.WfCompleted, Instance.WfCancelled, Instance.WfFailed] -> do-                        void (cancelTimer (row ^. #timerId))-                        pure Nothing-                _ -> do-                    targetGen <--                        case payloadGen of-                            Just gen -> pure gen-                            Nothing -> do-                                currentGen <- currentGeneration name wid-                                pure $-                                    fromMaybe-                                        currentGen-                                        (matchSleepTimerGeneration name wid currentGen full (row ^. #timerId))-                    now <- liftIO getCurrentTime-                    appendTx <--                        prepareJournalAppend-                            name-                            wid-                            targetGen-                            (StepRecorded{stepName = full, result = Null, recordedAt = now})-                    runTransaction (appendTx <* clearWorkflowWakeAfterTx name wid) >>= \case-                        JournalAppended{} ->-                            pure (Just (deterministicJournalId name wid targetGen full))-                        JournalAlreadyPresent{} ->-                            pure (Just (deterministicJournalId name wid targetGen full))-                        JournalAppendConflict err ->-                            throwIO (WorkflowJournalAppendError (Text.pack (show err)))--{- | A timer worker pass that handles __both__ workflow-sleep timers and-ordinary process-manager timers. For each claimed timer: if its payload is a-workflow sleep, wake the workflow; otherwise delegate to the supplied-process-manager fire action.+  case parseSleepPayload (row ^. #payload) of+    Nothing -> pure Nothing+    Just (full, payloadGen) -> do+      let name = WorkflowName (row ^. #processManagerName)+          wid = WorkflowId (row ^. #correlationId)+      Instance.lookupInstance name wid >>= \case+        Just instanceRow+          | instanceRow ^. #status+              `elem` [Instance.WfCompleted, Instance.WfCancelled, Instance.WfFailed] -> do+              void (cancelTimer (row ^. #timerId))+              pure Nothing+        _ -> do+          targetGen <-+            case payloadGen of+              Just gen -> pure gen+              Nothing -> do+                currentGen <- currentGeneration name wid+                pure $+                  fromMaybe+                    currentGen+                    (matchSleepTimerGeneration name wid currentGen full (row ^. #timerId))+          now <- liftIO getCurrentTime+          appendTx <-+            prepareJournalAppend+              name+              wid+              targetGen+              (StepRecorded {stepName = full, result = Null, recordedAt = now})+          runTransaction (appendTx <* clearWorkflowWakeAfterTx name wid) >>= \case+            JournalAppended {} ->+              pure (Just (deterministicJournalId name wid targetGen full))+            JournalAlreadyPresent {} ->+              pure (Just (deterministicJournalId name wid targetGen full))+            JournalAppendConflict err ->+              throwIO (WorkflowJournalAppendError (Text.pack (show err))) -A deployment that runs only workflows can pass @\\_ -> pure Nothing@ as the-fallback (or use 'workflowSleepFireAction' directly with-'Keiro.Timer.runTimerWorker'). A deployment that mixes process-manager timers-and workflow sleeps passes its existing PM fire action so one worker drains-both kinds.--}+-- | A timer worker pass that handles __both__ workflow-sleep timers and+-- ordinary process-manager timers. For each claimed timer: if its payload is a+-- workflow sleep, wake the workflow; otherwise delegate to the supplied+-- process-manager fire action.+--+-- A deployment that runs only workflows can pass @\\_ -> pure Nothing@ as the+-- fallback (or use 'workflowSleepFireAction' directly with+-- 'Keiro.Timer.runTimerWorker'). A deployment that mixes process-manager timers+-- and workflow sleeps passes its existing PM fire action so one worker drains+-- both kinds. runWorkflowTimerWorker ::-    (IOE :> es, Store :> es) =>-    Maybe KeiroMetrics ->-    UTCTime ->-    -- | Fallback fire action for non-sleep (process-manager) timers.-    (TimerRow -> Eff es (Maybe EventId)) ->-    Eff es (Maybe TimerRow)+  (IOE :> es, Store :> es) =>+  Maybe KeiroMetrics ->+  UTCTime ->+  -- | Fallback fire action for non-sleep (process-manager) timers.+  (TimerRow -> Eff es (Maybe EventId)) ->+  Eff es (Maybe TimerRow) runWorkflowTimerWorker metrics now pmFire =-    runTimerWorker metrics now $ \row -> do-        handled <- workflowSleepFireAction row-        case handled of-            Just eid -> pure (Just eid)-            Nothing -> pmFire row+  runTimerWorker metrics now $ \row -> do+    handled <- workflowSleepFireAction row+    case handled of+      Just eid -> pure (Just eid)+      Nothing -> pmFire row
src/Keiro/Workflow/Snapshot.hs view
@@ -1,52 +1,51 @@-{- | Workflow journal snapshots: the workflow-specific 'StateCodec' and the-read\/write helpers the runtime uses to skip a full version-0 replay.--A durable workflow folds its journal stream into a 'WorkflowState' — a-@'Map' 'Text' 'Value'@ of step-name to encoded result. For a long-lived-workflow, re-reading the whole journal on every run and resume is ruinous.-This module supplies the EP-4 snapshot machinery the runtime reuses to-persist that folded map and, on the next run, seed from it and replay only-the tail.--== Why a workflow-specific codec--EP-4's 'Keiro.Snapshot.Codec.defaultStateCodec' derives its 'shapeHash' from-a /statically-known/ keiki register-file slot list-('Keiki.Shape.regFileShapeHash'). A workflow's step names are dynamic runtime-strings, so there is no static slot list. The accumulated state is instead a-self-describing JSON object, so it round-trips through Aeson trivially and its-/shape/ never varies with which steps ran. Hence the fixed sentinel-'workflowStateShapeHash'; per-step result-type evolution is each step's own-'Aeson.ToJSON'\/'Aeson.FromJSON' concern, surfaced at the @step@ decode in-"Keiro.Workflow", not here.--== Advisory semantics--A snapshot is an optimization, never a source of truth. 'loadWorkflowSnapshot'-returns 'Nothing' — meaning "replay from version 0" — when the stream has no-id yet, no matching snapshot, or an undecodable snapshot. So a stale or corrupt-snapshot degrades performance at worst, never correctness.--Runtime snapshot writes are advisory too. After a workflow journal append has-committed, "Keiro.Workflow" swallows any snapshot-store failure and increments-@keiro.snapshot.write.failures@; the committed step, completion, or rotation-therefore still determines a successful run. This low-level module continues-to expose the store primitive, while the runtime owns that error handling.--Snapshot writes store the full accumulated step map each time the selected-policy fires. With an every-n policy that means rewriting the complete map at-each boundary; the intended way to bound that cost for forever-running-workflows is 'Keiro.Workflow.continueAsNew', which starts a fresh generation-with a small carried seed.--}-module Keiro.Workflow.Snapshot (-    workflowStateCodec,+-- | Workflow journal snapshots: the workflow-specific 'StateCodec' and the+-- read\/write helpers the runtime uses to skip a full version-0 replay.+--+-- A durable workflow folds its journal stream into a 'WorkflowState' — a+-- @'Map' 'Text' 'Value'@ of step-name to encoded result. For a long-lived+-- workflow, re-reading the whole journal on every run and resume is ruinous.+-- This module supplies the EP-4 snapshot machinery the runtime reuses to+-- persist that folded map and, on the next run, seed from it and replay only+-- the tail.+--+-- == Why a workflow-specific codec+--+-- EP-4's 'Keiro.Snapshot.Codec.defaultStateCodec' derives its 'shapeHash' from+-- a /statically-known/ keiki register-file slot list+-- ('Keiki.Shape.regFileShapeHash'). A workflow's step names are dynamic runtime+-- strings, so there is no static slot list. The accumulated state is instead a+-- self-describing JSON object, so it round-trips through Aeson trivially and its+-- /shape/ never varies with which steps ran. Hence the fixed sentinel+-- 'workflowStateShapeHash'; per-step result-type evolution is each step's own+-- 'Aeson.ToJSON'\/'Aeson.FromJSON' concern, surfaced at the @step@ decode in+-- "Keiro.Workflow", not here.+--+-- == Advisory semantics+--+-- A snapshot is an optimization, never a source of truth. 'loadWorkflowSnapshot'+-- returns 'Nothing' — meaning "replay from version 0" — when the stream has no+-- id yet, no matching snapshot, or an undecodable snapshot. So a stale or corrupt+-- snapshot degrades performance at worst, never correctness.+--+-- Runtime snapshot writes are advisory too. After a workflow journal append has+-- committed, "Keiro.Workflow" swallows any snapshot-store failure and increments+-- @keiro.snapshot.write.failures@; the committed step, completion, or rotation+-- therefore still determines a successful run. This low-level module continues+-- to expose the store primitive, while the runtime owns that error handling.+--+-- Snapshot writes store the full accumulated step map each time the selected+-- policy fires. With an every-n policy that means rewriting the complete map at+-- each boundary; the intended way to bound that cost for forever-running+-- workflows is 'Keiro.Workflow.continueAsNew', which starts a fresh generation+-- with a small carried seed.+module Keiro.Workflow.Snapshot+  ( workflowStateCodec,     workflowStateCodecVersion,     workflowStateShapeHash,     lookupWorkflowSnapshot,     loadWorkflowSnapshot,     writeWorkflowSnapshot,-)+  ) where  import Data.Aeson (Result (..))@@ -61,77 +60,71 @@ import Kiroku.Store.Read (lookupStreamId) import Kiroku.Store.Types (StreamId, StreamName, StreamVersion) -{- | The codec version of the workflow snapshot envelope. Bumped only if the-map /envelope/ encoding itself changes (e.g. a switch from a bare JSON-object to a tagged container), never for a per-step result-type change.--}+-- | The codec version of the workflow snapshot envelope. Bumped only if the+-- map /envelope/ encoding itself changes (e.g. a switch from a bare JSON+-- object to a tagged container), never for a per-step result-type change. workflowStateCodecVersion :: Int workflowStateCodecVersion = 1 -{- | A FIXED sentinel shape hash. The accumulated state is always "a JSON-object of step-name strings to self-describing JSON values"; its /shape/-never varies with which steps ran, so the shape hash is constant. Per-step-result-type evolution is the step's own 'Aeson.ToJSON'\/'Aeson.FromJSON'-concern, surfaced at the step decode in "Keiro.Workflow", not here.--}+-- | A FIXED sentinel shape hash. The accumulated state is always "a JSON+-- object of step-name strings to self-describing JSON values"; its /shape/+-- never varies with which steps ran, so the shape hash is constant. Per-step+-- result-type evolution is the step's own 'Aeson.ToJSON'\/'Aeson.FromJSON'+-- concern, surfaced at the step decode in "Keiro.Workflow", not here. workflowStateShapeHash :: Text workflowStateShapeHash = "keiro.workflow.stepmap.v1" -{- | The workflow-specific 'StateCodec'. Encodes the accumulated-'WorkflowState' map straight to JSON and decodes it back, with a fixed-discriminant ('workflowStateCodecVersion', 'workflowStateShapeHash').--}+-- | The workflow-specific 'StateCodec'. Encodes the accumulated+-- 'WorkflowState' map straight to JSON and decodes it back, with a fixed+-- discriminant ('workflowStateCodecVersion', 'workflowStateShapeHash'). workflowStateCodec :: StateCodec WorkflowState workflowStateCodec =-    StateCodec-        { stateCodecVersion = workflowStateCodecVersion-        , shapeHash = workflowStateShapeHash-        , stateShapeHash = workflowStateShapeHash-        , encode = toJSON-        , decode = \value -> case fromJSON value of-            Success m -> Right m-            Error msg -> Left (Text.pack msg)-        }+  StateCodec+    { stateCodecVersion = workflowStateCodecVersion,+      shapeHash = workflowStateShapeHash,+      stateShapeHash = workflowStateShapeHash,+      encode = toJSON,+      decode = \value -> case fromJSON value of+        Success m -> Right m+        Error msg -> Left (Text.pack msg)+    } -{- | Encode the accumulated map and upsert @keiro_snapshots@ for the journal-stream. Called from the @step@ miss-path (and the completion site) with the-'Kiroku.Store.Types.AppendResult'\'s @streamId@ and post-append @streamVersion@.-The underlying upsert keeps only the highest version per stream, so a re-fire-at an already-snapshotted version is a harmless no-op.--}+-- | Encode the accumulated map and upsert @keiro_snapshots@ for the journal+-- stream. Called from the @step@ miss-path (and the completion site) with the+-- 'Kiroku.Store.Types.AppendResult'\'s @streamId@ and post-append @streamVersion@.+-- The underlying upsert keeps only the highest version per stream, so a re-fire+-- at an already-snapshotted version is a harmless no-op. writeWorkflowSnapshot :: (Store :> es) => StreamId -> StreamVersion -> WorkflowState -> Eff es () writeWorkflowSnapshot streamId version state =-    writeSnapshot streamId version workflowStateCodec state+  writeSnapshot streamId version workflowStateCodec state -{- | Resolve the journal stream id, look up the latest matching snapshot row,-and decode it to a @('WorkflowState', 'StreamVersion')@ seed. Returns-'Nothing' — meaning "replay from 0" — when the stream has no id yet, no-matching snapshot, or an undecodable snapshot (advisory semantics). Mirrors-'Keiro.Snapshot.hydrateWithSnapshot''s miss-is-benign contract.--}+-- | Resolve the journal stream id, look up the latest matching snapshot row,+-- and decode it to a @('WorkflowState', 'StreamVersion')@ seed. Returns+-- 'Nothing' — meaning "replay from 0" — when the stream has no id yet, no+-- matching snapshot, or an undecodable snapshot (advisory semantics). Mirrors+-- 'Keiro.Snapshot.hydrateWithSnapshot''s miss-is-benign contract. loadWorkflowSnapshot :: (Store :> es) => StreamName -> Eff es (Maybe (WorkflowState, StreamVersion)) loadWorkflowSnapshot journalName =-    lookupWorkflowSnapshot journalName <&> either (const Nothing) Just+  lookupWorkflowSnapshot journalName <&> either (const Nothing) Just -{- | Resolve and decode a workflow snapshot while retaining the reason a-usable seed was unavailable. This is the observable counterpart to-'loadWorkflowSnapshot'.--}+-- | Resolve and decode a workflow snapshot while retaining the reason a+-- usable seed was unavailable. This is the observable counterpart to+-- 'loadWorkflowSnapshot'. lookupWorkflowSnapshot :: (Store :> es) => StreamName -> Eff es (Either SnapshotMissReason (WorkflowState, StreamVersion)) lookupWorkflowSnapshot journalName = do-    mStreamId <- lookupStreamId journalName-    case mStreamId of-        Nothing -> pure (Left SnapshotNoStream)-        Just streamId -> do-            mRow <--                lookupSnapshot-                    streamId-                    workflowStateCodecVersion-                    workflowStateShapeHash-                    workflowStateShapeHash-            pure $ case mRow of-                Nothing -> Left SnapshotNotFound-                Just row ->-                    case (workflowStateCodec ^. #decode) (row ^. #state) of-                        Left message -> Left (SnapshotDecodeFailed message)-                        Right state -> Right (state, row ^. #streamVersion)+  mStreamId <- lookupStreamId journalName+  case mStreamId of+    Nothing -> pure (Left SnapshotNoStream)+    Just streamId -> do+      mRow <-+        lookupSnapshot+          streamId+          workflowStateCodecVersion+          workflowStateShapeHash+          workflowStateShapeHash+      pure $ case mRow of+        Nothing -> Left SnapshotNotFound+        Just row ->+          case (workflowStateCodec ^. #decode) (row ^. #state) of+            Left message -> Left (SnapshotDecodeFailed message)+            Right state -> Right (state, row ^. #streamVersion)
src/Keiro/Workflow/Types.hs view
@@ -1,25 +1,24 @@ {-# OPTIONS_GHC -Wno-partial-fields #-} -{- | Core types and the journal codec for the durable workflow runtime.--A /durable workflow/ is an ordinary @effectful@ computation whose side-effects are recorded ("journaled") at named checkpoints so the computation-can be paused and resumed across crashes without re-running work that-already happened. The journal is a kiroku stream named-@wf:\<workflow-name\>-\<workflow-id\>@ ('workflowStreamName') holding one-'StepRecorded' event per executed step and a terminal 'WorkflowCompleted'-event.--This module owns the contracts every sibling plan of the v2 MasterPlan-builds on: the identity newtypes ('WorkflowName', 'WorkflowId',-'StepName'), the journal event sum ('WorkflowJournalEvent') and its-'Codec' ('workflowJournalCodec'), the accumulated-state alias-('WorkflowState'), the run outcome ('WorkflowOutcome'), and the-reserved step-name conventions ('completedStepName' plus the-@sleep:@\/@awk:@\/@child:@ prefixes).--}-module Keiro.Workflow.Types (-    -- * Identity+-- | Core types and the journal codec for the durable workflow runtime.+--+-- A /durable workflow/ is an ordinary @effectful@ computation whose side+-- effects are recorded ("journaled") at named checkpoints so the computation+-- can be paused and resumed across crashes without re-running work that+-- already happened. The journal is a kiroku stream named+-- @wf:\<workflow-name\>-\<workflow-id\>@ ('workflowStreamName') holding one+-- 'StepRecorded' event per executed step and a terminal 'WorkflowCompleted'+-- event.+--+-- This module owns the contracts every sibling plan of the v2 MasterPlan+-- builds on: the identity newtypes ('WorkflowName', 'WorkflowId',+-- 'StepName'), the journal event sum ('WorkflowJournalEvent') and its+-- 'Codec' ('workflowJournalCodec'), the accumulated-state alias+-- ('WorkflowState'), the run outcome ('WorkflowOutcome'), and the+-- reserved step-name conventions ('completedStepName' plus the+-- @sleep:@\/@awk:@\/@child:@ prefixes).+module Keiro.Workflow.Types+  ( -- * Identity     WorkflowName (..),     WorkflowId (..),     WorkflowIdentityError (..),@@ -53,7 +52,7 @@     patchStepPrefix,     patchSetStepName,     patchStepName,-)+  ) where  import Data.Aeson qualified as Aeson@@ -65,340 +64,315 @@ import Keiro.Prelude import Kiroku.Store.Types (EventType (..), StreamName (..)) -{- | The stable name of a workflow /definition/ (for example-@"orderFulfillment"@). Part of the journal stream name and of every-deterministic journal-event id, so it must not change for a given definition-across deploys. Prefer 'mkWorkflowName' for new code; the raw constructor is-kept for compatibility and can create ambiguous journal stream names if the-text contains structural separators such as @-@, @:@, or @#@.--}+-- | The stable name of a workflow /definition/ (for example+-- @"orderFulfillment"@). Part of the journal stream name and of every+-- deterministic journal-event id, so it must not change for a given definition+-- across deploys. Prefer 'mkWorkflowName' for new code; the raw constructor is+-- kept for compatibility and can create ambiguous journal stream names if the+-- text contains structural separators such as @-@, @:@, or @#@. newtype WorkflowName = WorkflowName {unWorkflowName :: Text}-    deriving stock (Eq, Ord, Show, Generic)+  deriving stock (Eq, Ord, Show, Generic) -{- | The id of a single workflow /instance/ (a UUID-as-text or any stable-caller-supplied string). Combined with the 'WorkflowName' it identifies the-instance's journal stream. Prefer 'mkWorkflowId' for new code; the raw-constructor is kept for compatibility and can create ambiguous journal stream-names if the text contains structural separators such as @:@ or @#@.--}+-- | The id of a single workflow /instance/ (a UUID-as-text or any stable+-- caller-supplied string). Combined with the 'WorkflowName' it identifies the+-- instance's journal stream. Prefer 'mkWorkflowId' for new code; the raw+-- constructor is kept for compatibility and can create ambiguous journal stream+-- names if the text contains structural separators such as @:@ or @#@. newtype WorkflowId = WorkflowId {unWorkflowId :: Text}-    deriving stock (Eq, Ord, Show, Generic)+  deriving stock (Eq, Ord, Show, Generic)  data WorkflowIdentityError-    = WorkflowNameEmpty-    | WorkflowNameInvalidChar !Char !Text-    | WorkflowIdEmpty-    | WorkflowIdInvalidChar !Char !Text-    deriving stock (Eq, Show, Generic)--{- | Validated constructor for workflow names.+  = WorkflowNameEmpty+  | WorkflowNameInvalidChar !Char !Text+  | WorkflowIdEmpty+  | WorkflowIdInvalidChar !Char !Text+  deriving stock (Eq, Show, Generic) -Rejects empty names and the structural separators @:@ (stream prefix), @-@-(name/id boundary), and @#@ (generation suffix). Prefer camelCase compound-names such as @"orderFulfillment"@; the raw 'WorkflowName' constructor remains-available for compatibility.--}+-- | Validated constructor for workflow names.+--+-- Rejects empty names and the structural separators @:@ (stream prefix), @-@+-- (name/id boundary), and @#@ (generation suffix). Prefer camelCase compound+-- names such as @"orderFulfillment"@; the raw 'WorkflowName' constructor remains+-- available for compatibility. mkWorkflowName :: Text -> Either WorkflowIdentityError WorkflowName mkWorkflowName raw-    | Text.null raw = Left WorkflowNameEmpty-    | Just c <- Text.find (`elem` ([':', '-', '#'] :: [Char])) raw =-        Left (WorkflowNameInvalidChar c raw)-    | otherwise = Right (WorkflowName raw)--{- | Validated constructor for workflow ids.+  | Text.null raw = Left WorkflowNameEmpty+  | Just c <- Text.find (`elem` ([':', '-', '#'] :: [Char])) raw =+      Left (WorkflowNameInvalidChar c raw)+  | otherwise = Right (WorkflowName raw) -Rejects empty ids and the structural separators @:@ and @#@. The @-@ character-is permitted so UUID-style ids remain valid; with a validated, hyphen-free-workflow name, the @wf:\<name\>-\<id\>@ boundary is the first @-@.--}+-- | Validated constructor for workflow ids.+--+-- Rejects empty ids and the structural separators @:@ and @#@. The @-@ character+-- is permitted so UUID-style ids remain valid; with a validated, hyphen-free+-- workflow name, the @wf:\<name\>-\<id\>@ boundary is the first @-@. mkWorkflowId :: Text -> Either WorkflowIdentityError WorkflowId mkWorkflowId raw-    | Text.null raw = Left WorkflowIdEmpty-    | Just c <- Text.find (`elem` ([':', '#'] :: [Char])) raw =-        Left (WorkflowIdInvalidChar c raw)-    | otherwise = Right (WorkflowId raw)+  | Text.null raw = Left WorkflowIdEmpty+  | Just c <- Text.find (`elem` ([':', '#'] :: [Char])) raw =+      Left (WorkflowIdInvalidChar c raw)+  | otherwise = Right (WorkflowId raw) -{- | The label identifying a step within a workflow. Replay matches on this-label, not on source position, so reordering code between deploys does not-corrupt an in-flight workflow.--}+-- | The label identifying a step within a workflow. Replay matches on this+-- label, not on source position, so reordering code between deploys does not+-- corrupt an in-flight workflow. newtype StepName = StepName {unStepName :: Text}-    deriving stock (Eq, Ord, Show, Generic)+  deriving stock (Eq, Ord, Show, Generic) -{- | The stable identifier of a /patch/ (EP-49) — a guarded, cross-cutting change-to a running workflow's logic. The author chooses an opaque, never-reused string-(for example @"fraud-check-v2"@). A patch decision is journaled under the key-@patch:\<patchId\>@, so the id must not contain the structural @:@ in a way that-makes the prefix boundary ambiguous, mirroring the 'sleepStepPrefix' caveat.--}+-- | The stable identifier of a /patch/ (EP-49) — a guarded, cross-cutting change+-- to a running workflow's logic. The author chooses an opaque, never-reused string+-- (for example @"fraud-check-v2"@). A patch decision is journaled under the key+-- @patch:\<patchId\>@, so the id must not contain the structural @:@ in a way that+-- makes the prefix boundary ambiguous, mirroring the 'sleepStepPrefix' caveat. newtype PatchId = PatchId {unPatchId :: Text}-    deriving stock (Eq, Ord, Show, Generic)--{- | The journal stream name for a workflow instance:-@wf:\<name\>-\<id\>@.+  deriving stock (Eq, Ord, Show, Generic) -The @:@ and @-@ characters are structural, and generation streams reserve @#@.-Use 'mkWorkflowName' and 'mkWorkflowId' for separator-safe identities. Raw-unvalidated names containing @-@ can make two distinct @(name, id)@ pairs share-one journal stream (the v1 process-manager @pm:\<name\>-\<correlationId\>@-convention carries the same caveat).--}+-- | The journal stream name for a workflow instance:+-- @wf:\<name\>-\<id\>@.+--+-- The @:@ and @-@ characters are structural, and generation streams reserve @#@.+-- Use 'mkWorkflowName' and 'mkWorkflowId' for separator-safe identities. Raw+-- unvalidated names containing @-@ can make two distinct @(name, id)@ pairs share+-- one journal stream (the v1 process-manager @pm:\<name\>-\<correlationId\>@+-- convention carries the same caveat). workflowStreamName :: WorkflowName -> WorkflowId -> StreamName workflowStreamName (WorkflowName name) (WorkflowId wid) =-    StreamName ("wf:" <> name <> "-" <> wid)--{- | The PHYSICAL journal stream for a given /generation/ of a logical-workflow (EP-48 continue-as-new).+  StreamName ("wf:" <> name <> "-" <> wid) -Generation 0 keeps the legacy name @wf:\<name\>-\<id\>@ — so already-running,-never-rotated workflows are byte-for-byte unchanged and need zero data-migration — while generation @g > 0@ appends a @#\<g\>@ suffix. The @#@ is a-new structural separator, distinct from the @:@ and @-@ that-'workflowStreamName' already reserves, so it cannot collide with an existing-boundary. The /logical/ identity @('WorkflowName', 'WorkflowId')@ the author-and the resume registry see is stable across rotations; only the physical-stream the journal lives on rotates underneath it.--}+-- | The PHYSICAL journal stream for a given /generation/ of a logical+-- workflow (EP-48 continue-as-new).+--+-- Generation 0 keeps the legacy name @wf:\<name\>-\<id\>@ — so already-running,+-- never-rotated workflows are byte-for-byte unchanged and need zero data+-- migration — while generation @g > 0@ appends a @#\<g\>@ suffix. The @#@ is a+-- new structural separator, distinct from the @:@ and @-@ that+-- 'workflowStreamName' already reserves, so it cannot collide with an existing+-- boundary. The /logical/ identity @('WorkflowName', 'WorkflowId')@ the author+-- and the resume registry see is stable across rotations; only the physical+-- stream the journal lives on rotates underneath it. workflowGenerationStreamName :: WorkflowName -> WorkflowId -> Int -> StreamName workflowGenerationStreamName name wid gen-    | gen <= 0 = workflowStreamName name wid-    | otherwise =-        let StreamName base = workflowStreamName name wid-         in StreamName (base <> "#" <> Text.pack (show gen))--{- | The events written to a workflow journal.--* 'StepRecorded' — a step (identified by 'stepName') ran and produced-  'result' (the step's value encoded as JSON) at 'recordedAt'. The-  suspension primitives journal their completions as ordinary-  'StepRecorded' events whose 'stepName' carries a reserved prefix-  ('sleepStepPrefix', 'awakeableStepPrefix', 'childStepPrefix'); the-  replay loop stays uniform because there is no separate event type.-* 'WorkflowCompleted' — the terminal marker appended once the whole-  computation has returned.-* 'WorkflowCancelled' — a terminal marker (EP-43) written to a /child/-  workflow's journal by @cancelChild@; a run whose journal carries it-  short-circuits without executing further steps and reports-  'Keiro.Workflow.Types.Cancelled'.-* 'WorkflowFailed' — a terminal failure marker (carries a 'reason'),-  available for a worker to record a permanently-failed run.+  | gen <= 0 = workflowStreamName name wid+  | otherwise =+      let StreamName base = workflowStreamName name wid+       in StreamName (base <> "#" <> Text.pack (show gen)) -These last two are purely additive within @schemaVersion = 1@ (a new wire-tag added to 'workflowJournalCodec''s 'eventTypes'; old journals never carry-it, so no upcaster is needed). The codec is deliberately the single place to-extend.--}+-- | The events written to a workflow journal.+--+-- * 'StepRecorded' — a step (identified by 'stepName') ran and produced+--   'result' (the step's value encoded as JSON) at 'recordedAt'. The+--   suspension primitives journal their completions as ordinary+--   'StepRecorded' events whose 'stepName' carries a reserved prefix+--   ('sleepStepPrefix', 'awakeableStepPrefix', 'childStepPrefix'); the+--   replay loop stays uniform because there is no separate event type.+-- * 'WorkflowCompleted' — the terminal marker appended once the whole+--   computation has returned.+-- * 'WorkflowCancelled' — a terminal marker (EP-43) written to a /child/+--   workflow's journal by @cancelChild@; a run whose journal carries it+--   short-circuits without executing further steps and reports+--   'Keiro.Workflow.Types.Cancelled'.+-- * 'WorkflowFailed' — a terminal failure marker (carries a 'reason'),+--   available for a worker to record a permanently-failed run.+--+-- These last two are purely additive within @schemaVersion = 1@ (a new wire+-- tag added to 'workflowJournalCodec''s 'eventTypes'; old journals never carry+-- it, so no upcaster is needed). The codec is deliberately the single place to+-- extend. data WorkflowJournalEvent-    = StepRecorded {stepName :: !Text, result :: !Aeson.Value, recordedAt :: !UTCTime}-    | WorkflowCompleted {recordedAt :: !UTCTime}-    | WorkflowCancelled {recordedAt :: !UTCTime}-    | WorkflowFailed {reason :: !Text, recordedAt :: !UTCTime}-    | {- | Terminal-for-this-generation rotation marker (EP-48). 'generation'-      is the NEXT generation this rotation opens. Additive within-      @schemaVersion = 1@: old journals never carry the-      @"WorkflowContinuedAsNew"@ tag, so no upcaster is needed.-      -}-      WorkflowContinuedAsNew {generation :: !Int, recordedAt :: !UTCTime}-    deriving stock (Eq, Show, Generic)+  = StepRecorded {stepName :: !Text, result :: !Aeson.Value, recordedAt :: !UTCTime}+  | WorkflowCompleted {recordedAt :: !UTCTime}+  | WorkflowCancelled {recordedAt :: !UTCTime}+  | WorkflowFailed {reason :: !Text, recordedAt :: !UTCTime}+  | -- | Terminal-for-this-generation rotation marker (EP-48). 'generation'+    --       is the NEXT generation this rotation opens. Additive within+    --       @schemaVersion = 1@: old journals never carry the+    --       @"WorkflowContinuedAsNew"@ tag, so no upcaster is needed.+    WorkflowContinuedAsNew {generation :: !Int, recordedAt :: !UTCTime}+  deriving stock (Eq, Show, Generic) -{- | The 'Codec' that serializes 'WorkflowJournalEvent' to and from the-JSON payloads stored on the journal stream. Schema version 1; no-upcasters. Each payload is self-describing (it carries a @"kind"@-discriminator) so 'decode' can reconstruct the constructor from the-payload alone.--}+-- | The 'Codec' that serializes 'WorkflowJournalEvent' to and from the+-- JSON payloads stored on the journal stream. Schema version 1; no+-- upcasters. Each payload is self-describing (it carries a @"kind"@+-- discriminator) so 'decode' can reconstruct the constructor from the+-- payload alone. workflowJournalCodec :: Codec WorkflowJournalEvent workflowJournalCodec =-    Codec-        { eventTypes = EventType "StepRecorded" :| [EventType "WorkflowCompleted", EventType "WorkflowCancelled", EventType "WorkflowFailed", EventType "WorkflowContinuedAsNew"]-        , eventType = \case-            StepRecorded{} -> EventType "StepRecorded"-            WorkflowCompleted{} -> EventType "WorkflowCompleted"-            WorkflowCancelled{} -> EventType "WorkflowCancelled"-            WorkflowFailed{} -> EventType "WorkflowFailed"-            WorkflowContinuedAsNew{} -> EventType "WorkflowContinuedAsNew"-        , schemaVersion = 1-        , encode = encodeJournalEvent-        , decode = decodeJournalEvent-        , upcasters = []-        }+  Codec+    { eventTypes = EventType "StepRecorded" :| [EventType "WorkflowCompleted", EventType "WorkflowCancelled", EventType "WorkflowFailed", EventType "WorkflowContinuedAsNew"],+      eventType = \case+        StepRecorded {} -> EventType "StepRecorded"+        WorkflowCompleted {} -> EventType "WorkflowCompleted"+        WorkflowCancelled {} -> EventType "WorkflowCancelled"+        WorkflowFailed {} -> EventType "WorkflowFailed"+        WorkflowContinuedAsNew {} -> EventType "WorkflowContinuedAsNew",+      schemaVersion = 1,+      encode = encodeJournalEvent,+      decode = decodeJournalEvent,+      upcasters = []+    }  encodeJournalEvent :: WorkflowJournalEvent -> Aeson.Value encodeJournalEvent = \case-    StepRecorded name r t ->-        Aeson.object-            [ "kind" Aeson..= ("StepRecorded" :: Text)-            , "stepName" Aeson..= name-            , "result" Aeson..= r-            , "recordedAt" Aeson..= t-            ]-    WorkflowCompleted t ->-        Aeson.object-            [ "kind" Aeson..= ("WorkflowCompleted" :: Text)-            , "recordedAt" Aeson..= t-            ]-    WorkflowCancelled t ->-        Aeson.object-            [ "kind" Aeson..= ("WorkflowCancelled" :: Text)-            , "recordedAt" Aeson..= t-            ]-    WorkflowFailed r t ->-        Aeson.object-            [ "kind" Aeson..= ("WorkflowFailed" :: Text)-            , "reason" Aeson..= r-            , "recordedAt" Aeson..= t-            ]-    WorkflowContinuedAsNew g t ->-        Aeson.object-            [ "kind" Aeson..= ("WorkflowContinuedAsNew" :: Text)-            , "generation" Aeson..= g-            , "recordedAt" Aeson..= t-            ]+  StepRecorded name r t ->+    Aeson.object+      [ "kind" Aeson..= ("StepRecorded" :: Text),+        "stepName" Aeson..= name,+        "result" Aeson..= r,+        "recordedAt" Aeson..= t+      ]+  WorkflowCompleted t ->+    Aeson.object+      [ "kind" Aeson..= ("WorkflowCompleted" :: Text),+        "recordedAt" Aeson..= t+      ]+  WorkflowCancelled t ->+    Aeson.object+      [ "kind" Aeson..= ("WorkflowCancelled" :: Text),+        "recordedAt" Aeson..= t+      ]+  WorkflowFailed r t ->+    Aeson.object+      [ "kind" Aeson..= ("WorkflowFailed" :: Text),+        "reason" Aeson..= r,+        "recordedAt" Aeson..= t+      ]+  WorkflowContinuedAsNew g t ->+    Aeson.object+      [ "kind" Aeson..= ("WorkflowContinuedAsNew" :: Text),+        "generation" Aeson..= g,+        "recordedAt" Aeson..= t+      ]  decodeJournalEvent :: EventType -> Aeson.Value -> Either Text WorkflowJournalEvent decodeJournalEvent (EventType tag) value = first Text.pack (parseEither parser value)   where     parser = Aeson.withObject "WorkflowJournalEvent" $ \o -> do-        case tag of-            "StepRecorded" ->-                StepRecorded <$> o Aeson..: "stepName" <*> o Aeson..: "result" <*> o Aeson..: "recordedAt"-            "WorkflowCompleted" ->-                WorkflowCompleted <$> o Aeson..: "recordedAt"-            "WorkflowCancelled" ->-                WorkflowCancelled <$> o Aeson..: "recordedAt"-            "WorkflowFailed" ->-                WorkflowFailed <$> o Aeson..: "reason" <*> o Aeson..: "recordedAt"-            "WorkflowContinuedAsNew" ->-                WorkflowContinuedAsNew <$> o Aeson..: "generation" <*> o Aeson..: "recordedAt"-            other ->-                fail ("unknown workflow journal event type: " <> Text.unpack other)--{- | The accumulated step state a running workflow holds in memory: a map-from step name to that step's recorded JSON result. This is exactly the-value the journal carries, folded into a map.+      case tag of+        "StepRecorded" ->+          StepRecorded <$> o Aeson..: "stepName" <*> o Aeson..: "result" <*> o Aeson..: "recordedAt"+        "WorkflowCompleted" ->+          WorkflowCompleted <$> o Aeson..: "recordedAt"+        "WorkflowCancelled" ->+          WorkflowCancelled <$> o Aeson..: "recordedAt"+        "WorkflowFailed" ->+          WorkflowFailed <$> o Aeson..: "reason" <*> o Aeson..: "recordedAt"+        "WorkflowContinuedAsNew" ->+          WorkflowContinuedAsNew <$> o Aeson..: "generation" <*> o Aeson..: "recordedAt"+        other ->+          fail ("unknown workflow journal event type: " <> Text.unpack other) -This alias is the integration contract EP-41 (snapshots) consumes; it must-remain a @Map Text Value@ whose keys are dynamic step-name strings.--}+-- | The accumulated step state a running workflow holds in memory: a map+-- from step name to that step's recorded JSON result. This is exactly the+-- value the journal carries, folded into a map.+--+-- This alias is the integration contract EP-41 (snapshots) consumes; it must+-- remain a @Map Text Value@ whose keys are dynamic step-name strings. type WorkflowState = Map Text Aeson.Value -{- | The result of running a workflow.--* 'Completed' — the computation ran to its end and a 'WorkflowCompleted'-  event was journaled.-* 'Suspended' — the computation paused at an unresolved @awaitStep@; a-  wake source was armed and the run will be resumed later (by EP-42's-  resume worker) once the awaited result is journaled.--* 'Cancelled' — the run's journal carried a 'WorkflowCancelled' marker (a-  child cancelled by its parent, EP-43), so the handler short-circuited and-  executed nothing further. Distinct from 'Suspended' (which will resume) and-  'Completed' (which finished its work).-* 'Failed' — the run's journal carried a 'WorkflowFailed' marker, so the-  handler short-circuited and executed nothing further.--}+-- | The result of running a workflow.+--+-- * 'Completed' — the computation ran to its end and a 'WorkflowCompleted'+--   event was journaled.+-- * 'Suspended' — the computation paused at an unresolved @awaitStep@; a+--   wake source was armed and the run will be resumed later (by EP-42's+--   resume worker) once the awaited result is journaled.+--+-- * 'Cancelled' — the run's journal carried a 'WorkflowCancelled' marker (a+--   child cancelled by its parent, EP-43), so the handler short-circuited and+--   executed nothing further. Distinct from 'Suspended' (which will resume) and+--   'Completed' (which finished its work).+-- * 'Failed' — the run's journal carried a 'WorkflowFailed' marker, so the+--   handler short-circuited and executed nothing further. data WorkflowOutcome a-    = Completed a-    | Suspended-    | Cancelled-    | Failed-    | {- | EP-48: the run rotated onto a fresh journal generation via-      @continueAsNew@; a subsequent run/resume of the same logical id-      continues from the carried seed. Distinct from 'Suspended' (a wake-      source is pending) and 'Completed' (the workflow is done): a rotated-      workflow is still unfinished, so the resume worker re-invokes it and it-      proceeds on the new generation.-      -}-      ContinuedAsNew-    deriving stock (Eq, Show, Functor)+  = Completed a+  | Suspended+  | Cancelled+  | Failed+  | -- | EP-48: the run rotated onto a fresh journal generation via+    --       @continueAsNew@; a subsequent run/resume of the same logical id+    --       continues from the carried seed. Distinct from 'Suspended' (a wake+    --       source is pending) and 'Completed' (the workflow is done): a rotated+    --       workflow is still unfinished, so the resume worker re-invokes it and it+    --       proceeds on the new generation.+    ContinuedAsNew+  deriving stock (Eq, Show, Functor) -{- | The reserved step name written (as a 'WorkflowCompleted' journal event-and an index row) when a workflow finishes. The discovery query in-"Keiro.Workflow.Schema" ('Keiro.Workflow.Schema.findUnfinishedWorkflowIds')-treats a workflow lacking a row with this step name as unfinished, so the-literal here must match the literal in that SQL.--}+-- | The reserved step name written (as a 'WorkflowCompleted' journal event+-- and an index row) when a workflow finishes. The discovery query in+-- "Keiro.Workflow.Schema" ('Keiro.Workflow.Schema.findUnfinishedWorkflowIds')+-- treats a workflow lacking a row with this step name as unfinished, so the+-- literal here must match the literal in that SQL. completedStepName :: Text completedStepName = "__workflow_completed__" -{- | The reserved step name written (as a 'WorkflowCancelled' journal event and-an index row) when a workflow is cancelled. The replay handler short-circuits a-run that has a row with this step name, and-'Keiro.Workflow.Schema.findUnfinishedWorkflowIds' treats it (like-'completedStepName') as a terminal marker, so a cancelled workflow drops out of-resume discovery. The literal must match the literal in that SQL.--}+-- | The reserved step name written (as a 'WorkflowCancelled' journal event and+-- an index row) when a workflow is cancelled. The replay handler short-circuits a+-- run that has a row with this step name, and+-- 'Keiro.Workflow.Schema.findUnfinishedWorkflowIds' treats it (like+-- 'completedStepName') as a terminal marker, so a cancelled workflow drops out of+-- resume discovery. The literal must match the literal in that SQL. cancelledStepName :: Text cancelledStepName = "__workflow_cancelled__" -{- | The reserved step name written (as a 'WorkflowFailed' journal event and an-index row) when a workflow is recorded as permanently failed.--}+-- | The reserved step name written (as a 'WorkflowFailed' journal event and an+-- index row) when a workflow is recorded as permanently failed. failedStepName :: Text failedStepName = "__workflow_failed__" -{- | The reserved step name written (as a 'WorkflowContinuedAsNew' journal event-and an index row) when a workflow's generation rotates via @continueAsNew@-(EP-48). Its presence on a generation's index row makes that generation terminal-/for itself/ (a rotated-away generation drops out of any per-generation-"unfinished" check); the /current/ generation is the one with no terminal marker-row. Distinct from 'completedStepName'/'cancelledStepName': a rotated workflow is-NOT finished — its work continues on the next generation —-so 'Keiro.Workflow.Schema.findUnfinishedWorkflowIds' deliberately scopes its-terminal-marker check to the current (MAX) generation and does not treat-'continuedAsNewStepName' as terminal for the logical workflow.--}+-- | The reserved step name written (as a 'WorkflowContinuedAsNew' journal event+-- and an index row) when a workflow's generation rotates via @continueAsNew@+-- (EP-48). Its presence on a generation's index row makes that generation terminal+-- /for itself/ (a rotated-away generation drops out of any per-generation+-- "unfinished" check); the /current/ generation is the one with no terminal marker+-- row. Distinct from 'completedStepName'/'cancelledStepName': a rotated workflow is+-- NOT finished — its work continues on the next generation —+-- so 'Keiro.Workflow.Schema.findUnfinishedWorkflowIds' deliberately scopes its+-- terminal-marker check to the current (MAX) generation and does not treat+-- 'continuedAsNewStepName' as terminal for the logical workflow. continuedAsNewStepName :: Text continuedAsNewStepName = "__workflow_continued_as_new__" -{- | The reserved step name under which @continueAsNew@ (EP-48) carries the-author's seed value into the next generation. On rotation the runtime appends a-single @StepRecorded continueSeedStepName seedJson@ to the next generation's-journal (and snapshots it); the next run's body reads it back via @restoreSeed@-— an ordinary journaled @step@ — so the carried state is restored without-re-running anything. The leading/trailing @__@ marks it reserved, like the-other @__workflow_*__@ names.--}+-- | The reserved step name under which @continueAsNew@ (EP-48) carries the+-- author's seed value into the next generation. On rotation the runtime appends a+-- single @StepRecorded continueSeedStepName seedJson@ to the next generation's+-- journal (and snapshots it); the next run's body reads it back via @restoreSeed@+-- — an ordinary journaled @step@ — so the carried state is restored without+-- re-running anything. The leading/trailing @__@ marks it reserved, like the+-- other @__workflow_*__@ names. continueSeedStepName :: Text continueSeedStepName = "__workflow_seed__" -{- | Reserved step-name prefix EP-39 uses to journal a durable @sleep@'s-completion. Integration contract: EP-39 must use exactly this string.--}+-- | Reserved step-name prefix EP-39 uses to journal a durable @sleep@'s+-- completion. Integration contract: EP-39 must use exactly this string. sleepStepPrefix :: Text sleepStepPrefix = "sleep:" -{- | Reserved step-name prefix EP-40 uses to journal an awakeable's-completion. Integration contract: EP-40 must use exactly this string.--}+-- | Reserved step-name prefix EP-40 uses to journal an awakeable's+-- completion. Integration contract: EP-40 must use exactly this string. awakeableStepPrefix :: Text awakeableStepPrefix = "awk:" -{- | Reserved step-name prefix used to journal the random id allocated for an-awakeable. The id is random for new allocations but replay-stable because it is-recorded under @awkid:\<label\>@ before the workflow awaits @awk:\<uuid\>@.--}+-- | Reserved step-name prefix used to journal the random id allocated for an+-- awakeable. The id is random for new allocations but replay-stable because it is+-- recorded under @awkid:\<label\>@ before the workflow awaits @awk:\<uuid\>@. awakeableAllocStepPrefix :: Text awakeableAllocStepPrefix = "awkid:" -{- | Reserved step-name prefix EP-43 uses to journal a child workflow's-completion. Integration contract: EP-43 must use exactly this string.--}+-- | Reserved step-name prefix EP-43 uses to journal a child workflow's+-- completion. Integration contract: EP-43 must use exactly this string. childStepPrefix :: Text childStepPrefix = "child:" -{- | Reserved step-name prefix EP-49 uses to journal a 'patch' decision. A patch-decision is journaled as an ordinary 'StepRecorded' event whose 'stepName' is-@'patchStepPrefix' <> 'unPatchId' pid@ and whose 'result' is the JSON 'Bool'-branch decision, so the replay loop and the step index stay uniform — no new-journal-event constructor is added.--}+-- | Reserved step-name prefix EP-49 uses to journal a 'patch' decision. A patch+-- decision is journaled as an ordinary 'StepRecorded' event whose 'stepName' is+-- @'patchStepPrefix' <> 'unPatchId' pid@ and whose 'result' is the JSON 'Bool'+-- branch decision, so the replay loop and the step index stay uniform — no new+-- journal-event constructor is added. patchStepPrefix :: Text patchStepPrefix = "patch:" -{- | Reserved step name under which a workflow generation records the patch ids-that were active when that generation first started.--}+-- | Reserved step name under which a workflow generation records the patch ids+-- that were active when that generation first started. patchSetStepName :: Text patchSetStepName = "__workflow_patches__"
test/Main.hs view
@@ -1,12807 +1,12808 @@-module Main (-    main,-)-where--import Contravariant.Extras (contrazip2, contrazip3, contrazip4, contrazip5, contrazip6)-import Control.Concurrent (forkIO, killThread, threadDelay)-import Control.Concurrent.MVar (MVar, modifyMVar, newEmptyMVar, newMVar, putMVar, readMVar, takeMVar, tryPutMVar)-import Control.Concurrent.STM (atomically, putTMVar)-import Control.Exception (ErrorCall, Exception, SomeException, displayException, evaluate, finally, throwIO, try)-import Data.Aeson (object, withObject, (.:), (.:?))-import Data.Aeson qualified as Aeson-import Data.Aeson.KeyMap qualified as KeyMap-import Data.Aeson.Types (parseEither)-import Data.ByteString (ByteString)-import Data.IORef (IORef, atomicModifyIORef', modifyIORef', newIORef, readIORef, writeIORef)-import Data.Int (Int32)-import Data.List (isInfixOf)-import Data.Map.Strict qualified as Map-import Data.Monoid (mempty)-import Data.Set qualified as Set-import Data.Text qualified as Text-import Data.Text.Encoding qualified as TE-import Data.Time (NominalDiffTime, UTCTime (..), addUTCTime, diffUTCTime, secondsToDiffTime)-import Data.Time.Calendar (Day (ModifiedJulianDay))-import Data.UUID (UUID, fromString, fromWords64)-import Data.UUID qualified as UUID-import Data.Vector qualified as Vector-import Data.Word (Word64)-import Effectful (Eff, IOE, (:>))-import Effectful.Error.Static (Error, throwError)-import Effectful.Exception qualified as EffException-import GHC.Conc (ThreadStatus (..), threadStatus)-import Hasql.Decoders qualified as D-import Hasql.Encoders qualified as E-import Hasql.Statement (Statement, preparable)-import Keiki.Core (-    Edge (..),-    HsPred (..),-    InCtor (..),-    IndexN,-    RegFile (..),-    SymTransducer (..),-    Update (..),-    WireCtor (..),-    inpCtor,-    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.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.EventStream (Terminality (..))-import Keiro.EventStream.Validate (-    EventStreamWarning (..),-    ValidatedEventStream,-    mkEventStream,-    mkEventStreamOrThrow,-    mkEventStreamUnchecked,-    mkEventStreamWith,-    validateEventStream,- )-import Keiro.Inbox (-    InboxDedupePolicy (..),-    InboxError (..),-    InboxPersistence (..),-    InboxResult (..),-    InboxStatus (..),-    KafkaDeliveryRef (..),-    garbageCollectCompleted,-    listInbox,-    lookupInbox,-    markFailedTx,-    runInboxTransaction,-    runInboxTransactionBatch,-    runInboxTransactionWith,-    runInboxTransactionWithRetries,-    runInboxTransactionWithRetriesWith,-    sampleInboxBacklog,- )-import Keiro.Inbox.Kafka qualified as InboxKafka-import Keiro.Integration.Event (-    IntegrationContentType (..),-    IntegrationEvent (..),-    SchemaReference (..),-    TraceContext (..),-    decodeJsonIntegrationEvent,-    encodeJsonIntegrationEvent,-    headerContentType,-    headerMessageId,-    headerSchemaSubject,-    headerSchemaVersion,-    headerSourceEventId,-    headerSourceGlobalPosition,-    headerTraceParent,-    integrationHeaders,-    integrationPayload,-    parseContentType,- )-import Keiro.Integration.Event qualified as IntegrationEvent-import Keiro.Outbox (-    BackoffSchedule (..),-    ExponentialBackoffOptions (..),-    IntegrationEventDraft (..),-    IntegrationProducer (..),-    IntegrationProducerConfigError (..),-    OrderingPolicy (..),-    OutboxId (..),-    OutboxPublishConfigError (..),-    OutboxRow (..),-    OutboxStatus (..),-    PublishOutcome (..),-    claimOutboxBatch,-    defaultMaintenanceOptions,-    defaultPublishOptions,-    draftToEvent,-    enqueueIntegrationEventTx,-    freshOutboxId,-    garbageCollectSent,-    lookupOutbox,-    markOutboxSent,-    mintIntegrationEvent,-    mkIntegrationProducer,-    mkOutboxPublishOptions,-    outboxMaintenancePass,-    publishClaimedOutbox,-    sampleOutboxBacklog,- )-import Keiro.Outbox.Kafka qualified as OutboxKafka-import Keiro.Outbox.Schema (markOutboxFailedTx)-import Keiro.Prelude-import Keiro.ProcessManager-import Keiro.Projection-import Keiro.ReadModel-import Keiro.ReadModel.Rebuild qualified as Rebuild-import Keiro.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 (..),-    withFreshResourceStore,-    withFreshResourceStoreWith,-    withFreshStore,-    withFreshStoreWith,-    withFreshStores2,-    withMigratedSuite,- )-import Keiro.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,-    continueAsNew,-    currentGeneration,-    defaultWorkflowRunOptions,-    findUnfinishedWorkflowIds,-    loadStepIndex,-    mkWorkflowId,-    mkWorkflowName,-    patch,-    patchSetStepName,-    patchStepName,-    restoreSeed,-    runWorkflow,-    runWorkflowWith,-    step,-    stepExists,-    workflowGenerationStreamName,-    workflowJournalCodec,- )-import Keiro.Workflow.Awakeable (-    AwakeableId (..),-    WorkflowAwakeableCancelled (..),-    awakeableIdText,-    awakeableIdToUuid,-    awakeableNamed,-    cancelAwakeable,-    deterministicAwakeableId,-    signalAwakeable,-    signalAwakeableFrom,- )-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 (-    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 OpenTelemetry.Attributes (Attribute (..), Attributes, PrimitiveAttribute (..), lookupAttribute)-import OpenTelemetry.Attributes.Key (AttributeKey, unkey)-import OpenTelemetry.Exporter.InMemory.Metric (inMemoryMetricExporter)-import OpenTelemetry.Exporter.InMemory.Span (inMemoryListExporter)-import OpenTelemetry.Exporter.Metric (-    GaugeDataPoint (..),-    HistogramDataPoint (..),-    MetricExport (..),-    NumberValue (..),-    ResourceMetricsExport (..),-    ScopeMetricsExport (..),-    SumDataPoint (..),- )-import OpenTelemetry.MeterProvider (-    SdkMeterProviderOptions (..),-    createMeterProvider,-    defaultSdkMeterProviderOptions,- )-import OpenTelemetry.Metric.Core (-    forceFlushMeterProvider,-    getMeter,- )-import OpenTelemetry.Resource (emptyMaterializedResources)-import OpenTelemetry.Trace (-    SpanStatus (..),-    createTracerProvider,-    emptyTracerProviderOptions,-    makeTracer,-    shutdownTracerProvider,-    tracerOptions,- )-import OpenTelemetry.Trace.Core (-    ImmutableSpan (..),-    Span,-    SpanContext (..),-    SpanHot (..),-    SpanKind,-    getSpanContext,- )-import Shibuya.Adapter (Adapter (..))-import Shibuya.Core.Ack (AckDecision (..), DeadLetterReason (..), HaltReason (..), RetryDelay (..))-import Shibuya.Core.AckHandle (AckHandle (..))-import Shibuya.Core.Ingested (Ingested (..))-import Shibuya.Core.Types (Envelope (..))-import Streamly.Data.Stream qualified as Streamly-import System.Exit (ExitCode (..))-import System.Process (readProcessWithExitCode)-import System.Timeout (timeout)-import Test.Hspec-import "hasql-transaction" Hasql.Transaction qualified as Tx--main :: IO ()-main = withMigratedSuite $ \fixture -> hspec $ do-    describe "Keiro" $ do-        it "exposes the scaffold version" $-            KeiroRoot.version `shouldBe` ("0.4.0.0" :: Text)--    describe "Keiro.Telemetry metrics" $ do-        it "records instrument names and values through an SDK meter" $ do-            (exporter, ref) <- inMemoryMetricExporter-            (provider, _env) <--                createMeterProvider-                    emptyMaterializedResources-                    defaultSdkMeterProviderOptions{metricExporter = Just exporter}-            meter <- getMeter provider Telemetry.keiroInstrumentationLibrary-            metrics <- Telemetry.newKeiroMetrics meter-            let h = Just metrics-            -- A counter (monotonic sum), a gauge (last value wins), a histogram.-            Telemetry.recordOutboxPublished h 3-            Telemetry.recordOutboxPublished h 2-            Telemetry.recordOutboxBacklog h 7-            Telemetry.recordInboxDuplicates h 1-            Telemetry.recordTimerFireLag h 12.5-            _ <- forceFlushMeterProvider provider Nothing-            exported <- readIORef ref-            let scalars = flattenScalarPoints exported-                hists = flattenHistogramPoints exported-            -- The counter accumulated 3 + 2 = 5.-            lookup "keiro.outbox.published" scalars `shouldBe` Just (IntNumber 5)-            -- The gauge holds its last recorded value.-            lookup "keiro.outbox.backlog" scalars `shouldBe` Just (IntNumber 7)-            -- The duplicate counter holds 1.-            lookup "keiro.inbox.duplicates" scalars `shouldBe` Just (IntNumber 1)-            -- The histogram saw one observation summing to 12.5.-            let lag = [(c, s) | (n, c, s) <- hists, n == "keiro.timer.fire.lag"]-            lag `shouldBe` [(1, 12.5)]-            -- Instruments we never recorded export no points.-            lookup "keiro.timer.stuck" scalars `shouldBe` Nothing--        it "records nothing through a Nothing handle" $ do-            (exporter, ref) <- inMemoryMetricExporter-            (provider, _env) <--                createMeterProvider-                    emptyMaterializedResources-                    defaultSdkMeterProviderOptions{metricExporter = Just exporter}-            -- A Nothing handle is the no-op path: helpers must short-circuit.-            let h = Nothing-            Telemetry.recordOutboxPublished h 99-            Telemetry.recordOutboxBacklog h 99-            Telemetry.recordTimerFireLag h 99.0-            _ <- forceFlushMeterProvider provider Nothing-            exported <- readIORef ref-            flattenScalarPoints exported `shouldBe` []-            flattenHistogramPoints exported `shouldBe` []--    describe "Kiroku retry exhaustion observability" $ do-        it "dead-letters after the configured delivery bound, emits the metric, and advances" $ do-            (exporter, metricsRef) <- inMemoryMetricExporter-            (provider, _env) <--                createMeterProvider-                    emptyMaterializedResources-                    defaultSdkMeterProviderOptions{metricExporter = Just exporter}-            meter <- getMeter provider Telemetry.keiroInstrumentationLibrary-            metrics <- Telemetry.newKeiroMetrics meter-            forwarded <- newIORef (0 :: Int)-            let observe _ = modifyIORef' forwarded (+ 1)-                installBridge settings =-                    settings-                        & #eventHandler-                        .~ Just (Telemetry.kirokuEventBridge (Just metrics) observe)-            withFreshStoreWith fixture installBridge $ \store -> do-                total <- seedOrders store 1 2-                total `shouldBe` 2-                let subName = SubscriptionName "orders-retry-exhaustion"-                    subConfig =-                        ( KirokuSub.defaultSubscriptionConfig-                            subName-                            (Category (CategoryName "orders"))-                            (\_ -> pure KirokuSub.Continue)-                        )-                            { KirokuSub.retryPolicy = KirokuSub.RetryPolicy 2-                            }-                    pull label source = do-                        result <- timeout 5_000_000 (Streamly.uncons source)-                        case result of-                            Just (Just itemAndRest) -> pure itemAndRest-                            Just Nothing -> fail (label <> ": subscription ended early")-                            Nothing -> fail (label <> ": timed out waiting for delivery")-                    number item =-                        parseEither-                            (withObject "OrderPlaced" (.: "n"))-                            (ackEvent item ^. #payload)-                (stream0, cancelStream) <- subscriptionAckStream store subConfig 4-                ( do-                        (first, stream1) <- pull "initial poison delivery" stream0-                        ackAttempt first `shouldBe` 0-                        number first `shouldBe` Right (0 :: Int)-                        atomically $-                            putTMVar-                                (ackReply first)-                                (KirokuSub.Retry (KirokuSub.RetryDelay 0))--                        (retry, stream2) <- pull "poison redelivery" stream1-                        ackAttempt retry `shouldBe` 1-                        ackEvent retry ^. #eventId `shouldBe` ackEvent first ^. #eventId-                        atomically $-                            putTMVar-                                (ackReply retry)-                                (KirokuSub.Retry (KirokuSub.RetryDelay 0))--                        (next, stream3) <- pull "event after exhausted poison" stream2-                        ackAttempt next `shouldBe` 0-                        number next `shouldBe` Right (1 :: Int)-                        ackEvent next ^. #eventId `shouldNotBe` ackEvent first ^. #eventId-                        atomically (putTMVar (ackReply next) KirokuSub.Stop)-                        ended <- timeout 5_000_000 (Streamly.uncons stream3)-                        case ended of-                            Just Nothing -> pure ()-                            Just (Just _) -> expectationFailure "subscription delivered after Stop"-                            Nothing -> expectationFailure "subscription did not stop after the final acknowledgement"-                    )-                    `finally` cancelStream--                Right rows <--                    Store.runStoreIO store $-                        Store.runTransaction $-                            Tx.statement-                                ("orders-retry-exhaustion", 0)-                                KirokuSQL.readDeadLettersStmt-                case Vector.toList rows of-                    [row] -> do-                        row ^. #deadLetterReason-                            `shouldBe` object-                                [ "kind" Aeson..= ("max_attempts_exceeded" :: Text)-                                , "attempts" Aeson..= (2 :: Int)-                                ]-                        row ^. #deadLetterReasonSummary `shouldBe` "max retry attempts exceeded (2)"-                        row ^. #deadLetterAttemptCount `shouldBe` 2-                    other -> expectationFailure ("expected one Kiroku dead letter, got " <> show (Vector.length rows) <> ": " <> show other)--                _ <- forceFlushMeterProvider provider Nothing-                exported <- readIORef metricsRef-                lookup "keiro.subscription.deadlettered" (flattenScalarPoints exported)-                    `shouldBe` Just (IntNumber 1)-                readIORef forwarded >>= (`shouldSatisfy` (> 1))--    describe "Keiro.Stream" $ do-        it "wraps and unwraps kiroku stream names" $ do-            let orderStream = stream "order-123" :: Stream OrderStream-            Stream.streamName orderStream `shouldBe` StreamName "order-123"-            Stream.streamName (mapStreamName (\(StreamName name) -> StreamName (name <> "-archived")) orderStream)-                `shouldBe` StreamName "order-123-archived"--        it "validates categories, rejecting the dash boundary and reserved names" $ do-            fmap Stream.categoryText (Stream.category "incident" :: Either Stream.CategoryError (Stream.StreamCategory ()))-                `shouldBe` Right "incident"-            -- compound categories are camelCase; ':' (reserved for the wf: family) is also accepted-            fmap Stream.categoryText (Stream.category "hospitalSurge" :: Either Stream.CategoryError (Stream.StreamCategory ()))-                `shouldBe` Right "hospitalSurge"-            fmap Stream.categoryText (Stream.category "wf:fulfillment" :: Either Stream.CategoryError (Stream.StreamCategory ()))-                `shouldBe` Right "wf:fulfillment"-            (Stream.category "" :: Either Stream.CategoryError (Stream.StreamCategory ()))-                `shouldBe` Left Stream.CategoryEmpty-            (Stream.category "hospital-surge" :: Either Stream.CategoryError (Stream.StreamCategory ()))-                `shouldBe` Left (Stream.CategoryContainsSeparator "hospital-surge")-            (Stream.category "$all" :: Either Stream.CategoryError (Stream.StreamCategory ()))-                `shouldBe` Left (Stream.CategoryReserved "$all")-            (Stream.category "ord ers" :: Either Stream.CategoryError (Stream.StreamCategory ()))-                `shouldBe` Left (Stream.CategoryContainsIllegalChar ' ' "ord ers")-            (Stream.category "ord\ners" :: Either Stream.CategoryError (Stream.StreamCategory ()))-                `shouldBe` Left (Stream.CategoryContainsIllegalChar '\n' "ord\ners")--        it "builds entity streams that round-trip through kiroku's category rule" $ do-            let cat = Stream.categoryUnsafe "orders" :: Stream.StreamCategory OrderStream-            Stream.streamName (Stream.entityStream cat "1") `shouldBe` StreamName "orders-1"-            Stream.categoryName cat `shouldBe` CategoryName "orders"-            -- The category keiro reports equals kiroku's own parse of the produced-            -- name, even when the id segment itself contains a dash.-            Store.categoryName (Stream.streamName (Stream.entityStream cat "a-b-c"))-                `shouldBe` Stream.categoryName cat--        it "entityStreamId renders ids via StreamIdSegment (Text and String)" $ do-            let cat = Stream.categoryUnsafe "orders" :: Stream.StreamCategory OrderStream-            Stream.streamName (Stream.entityStreamId cat ("o-1" :: Text)) `shouldBe` StreamName "orders-o-1"-            Stream.streamName (Stream.entityStreamId cat ("o-1" :: String)) `shouldBe` StreamName "orders-o-1"--        it "rejects blank entity stream id segments" $ do-            let cat = Stream.categoryUnsafe "orders" :: Stream.StreamCategory OrderStream-            evaluate (Stream.streamName (Stream.entityStream cat "")) `shouldThrow` anyErrorCall-            evaluate (Stream.streamName (Stream.entityStream cat "   ")) `shouldThrow` anyErrorCall--    describe "Keiro.DeadLetter" $ around (withFreshStore fixture) $ do-        it "records a dispatch dead letter idempotently" $ \storeHandle -> do-            let deadLetter =-                    DispatchDeadLetter-                        { dispatcherKind = DispatcherProcessManager-                        , dispatcherName = "orders-pm"-                        , correlationId = "order-42"-                        , sourceEventId = EventId sampleUuid-                        , sourceGlobalPosition = GlobalPosition 17-                        , emitIndex = 0-                        , targetStreamName = StreamName "orders-42"-                        , errorClass = "command_rejected"-                        , errorDetail = Text.replicate 1100 "x"-                        , attemptCount = 2-                        }-            Right rows <--                Store.runStoreIO storeHandle $ do-                    recordDispatchDeadLetter deadLetter-                    recordDispatchDeadLetter deadLetter-                    listDispatchDeadLetters "orders-pm"-            case rows of-                [row] -> do-                    row ^. #dispatcherKind `shouldBe` DispatcherProcessManager-                    row ^. #dispatcherName `shouldBe` "orders-pm"-                    row ^. #correlationId `shouldBe` "order-42"-                    row ^. #sourceEventId `shouldBe` EventId sampleUuid-                    row ^. #sourceGlobalPosition `shouldBe` GlobalPosition 17-                    row ^. #emitIndex `shouldBe` 0-                    row ^. #targetStreamName `shouldBe` StreamName "orders-42"-                    row ^. #errorClass `shouldBe` "command_rejected"-                    Text.length (row ^. #errorDetail) `shouldBe` 1024-                    row ^. #attemptCount `shouldBe` 2-                other -> expectationFailure ("expected one idempotent dead-letter row, got " <> show other)--    describe "Keiro.Codec" $ do-        it "encodes current events with type tags and schema-version metadata" $ do-            encoded <- shouldBeRight (encodeForAppend orderCodec (OrderPlaced "order-123" 5))-            encoded ^. #eventType `shouldBe` EventType "OrderPlaced"-            encoded ^. #payload `shouldBe` object ["orderId" Aeson..= ("order-123" :: Text), "quantity" Aeson..= (5 :: Int)]-            extractSchemaVersion (recordedFrom encoded) `shouldBe` Right 2--        it "round-trips current events" $ do-            encoded <- shouldBeRight (encodeForAppend orderCodec (OrderPlaced "order-123" 5))-            decodeRecorded orderCodec (recordedFrom encoded) `shouldBe` Right (OrderPlaced "order-123" 5)--        it "decodes by the stored tag, not by payload shape (H1)" $ do-            let recorded =-                    recordedFrom-                        EventData-                            { eventId = Nothing-                            , eventType = EventType "CounterAudited"-                            , payload = object ["amount" Aeson..= (5 :: Int)]-                            , metadata = Just (metadataForOrDie 1 Nothing)-                            , causationId = Nothing-                            , correlationId = Nothing-                            }-            decodeRecorded counterCodec recorded `shouldBe` Right (CounterAudited 5)--        it "runs upcasters in source-version order" $-            decodeRaw orderCodec (EventType "OrderPlaced") 1 (object ["orderId" Aeson..= ("order-123" :: Text), "qty" Aeson..= (5 :: Int)])-                `shouldBe` Right (OrderPlaced "order-123" 5)--        it "rejects gaps in upcaster chains" $-            decodeRaw gappyCodec (EventType "OrderPlaced") 1 (object ["orderId" Aeson..= ("order-123" :: Text), "qty" Aeson..= (5 :: Int)])-                `shouldBe` Left (GapInUpcasterChain 2 3)--        it "validates codec construction invariants" $ do-            fmap (const ()) (mkCodec (orderCodec{schemaVersion = 0})) `shouldBe` Left (CodecSchemaVersionInvalid 0)-            fmap (const ()) (mkCodec (orderCodec{eventTypes = EventType "OrderPlaced" :| [EventType "OrderPlaced"]}))-                `shouldBe` Left (CodecDuplicateEventTypes [EventType "OrderPlaced"])-            fmap (const ()) (mkCodec (orderCodec{schemaVersion = 3, upcasters = [(1, const upcastOrderPlacedV1), (1, const upcastOrderPlacedV1)]}))-                `shouldBe` Left (CodecDuplicateUpcasterSources [1])-            fmap (const ()) (mkCodec (orderCodec{schemaVersion = 3, upcasters = [(1, const upcastOrderPlacedV1)]}))-                `shouldBe` Left (CodecUpcasterChainIncomplete [2] 3)-            case mkCodec orderCodec of-                Right _ -> pure ()-                Left err -> expectationFailure ("expected orderCodec to validate, got " <> show err)--        it "rejects future-version, malformed metadata, and incomplete upcaster chains" $ do-            let v1Payload = object ["orderId" Aeson..= ("order-123" :: Text), "qty" Aeson..= (5 :: Int)]-                earlyEndCodec =-                    orderCodec-                        { schemaVersion = 4-                        , upcasters = [(1, const upcastOrderPlacedV1), (2, const Right)]-                        }-            decodeRaw orderCodec (EventType "OrderPlaced") 3 v1Payload-                `shouldBe` Left (VersionAhead 3 2)-            decodeRaw earlyEndCodec (EventType "OrderPlaced") 1 v1Payload-                `shouldBe` Left (IncompleteUpcasterChain 3 4)--            let malformedStamp =-                    recordedFrom-                        EventData-                            { eventId = Nothing-                            , eventType = EventType "OrderPlaced"-                            , payload = object ["orderId" Aeson..= ("order-123" :: Text), "quantity" Aeson..= (5 :: Int)]-                            , metadata = Just (object ["schemaVersion" Aeson..= ("2" :: Text)])-                            , causationId = Nothing-                            , correlationId = Nothing-                            }-            extractSchemaVersion malformedStamp-                `shouldBe` Left (MalformedSchemaVersionStamp (Aeson.String "2"))-            fmap (const ()) (encodeForAppendWithMetadata orderCodec (Just (Aeson.String "x")) (OrderPlaced "order-123" 5))-                `shouldBe` Left (NonObjectCallerMetadata (Aeson.String "x"))--        it "rejects recorded events with unknown type tags" $ do-            let encoded =-                    recordedFrom-                        EventData-                            { eventId = Nothing-                            , eventType = EventType "OrderCancelled"-                            , payload = object ["orderId" Aeson..= ("order-123" :: Text)]-                            , metadata = Just (metadataForOrDie 2 Nothing)-                            , causationId = Nothing-                            , correlationId = Nothing-                            }-            decodeRecorded orderCodec encoded-                `shouldBe` Left (UnknownEventType (EventType "OrderCancelled") [EventType "OrderPlaced"])--    describe "Keiro.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.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"-                    , "test/ReplaySafetyTypeProbe.hs"-                    ]-                    ""-            exitCode `shouldSatisfy` (/= ExitSuccess)-            stderr `shouldSatisfy` ("ValidatedEventStream" `isInfixOf`)--    describe "Keiro.Command" $ around (withFreshStore fixture) $ do-        it "creates a stream and appends the first command event" $ \storeHandle -> do-            let target = stream "counter-command-create" :: Stream CounterEventStream-            result <--                Store.runStoreIO storeHandle $-                    runCommand defaultRunCommandOptions counterEventStream target (Add 2)-            case result of-                Right (Right commandResult) -> do-                    commandResult ^. #streamVersion `shouldBe` StreamVersion 1-                    commandResult ^. #eventsAppended `shouldBe` 1-                    commandResult ^. #globalPosition `shouldSatisfy` isJust-                other -> expectationFailure ("expected successful command, got " <> show other)-            Right recorded <--                Store.runStoreIO storeHandle $-                    Store.readStreamForward (StreamName "counter-command-create") (StreamVersion 0) 10-            Vector.length recorded `shouldBe` 1-            traverse (decodeRecorded counterCodec) (Vector.toList recorded)-                `shouldBe` Right [CounterAdded 2]--        it "reports no global position for a no-op after prior events" $ \storeHandle -> do-            let target = stream "skip-command-no-op-position" :: Stream SkipEventStream-            Right (Right appended) <--                Store.runStoreIO storeHandle $-                    runCommand defaultRunCommandOptions skipEventStream target (SAdd 2)-            appended ^. #globalPosition `shouldSatisfy` isJust-            result <--                Store.runStoreIO storeHandle $-                    runCommand defaultRunCommandOptions skipEventStream target SSkip-            case result of-                Right (Right noOp) -> do-                    noOp ^. #streamVersion `shouldBe` StreamVersion 1-                    noOp ^. #eventsAppended `shouldBe` 0-                    noOp ^. #globalPosition `shouldBe` Nothing-                other -> expectationFailure ("expected successful no-op command, got " <> show other)--        it "surfaces runtime edge ambiguity without appending" $ \storeHandle -> do-            (processor, spansRef) <- inMemoryListExporter-            provider <- createTracerProvider [processor] emptyTracerProviderOptions-            let tracer = makeTracer provider "keiro-test" tracerOptions-                target = stream "counter-command-ambiguous" :: Stream CounterEventStream-                options = defaultRunCommandOptions & #tracer ?~ tracer-            result <--                Store.runStoreIO storeHandle $-                    runCommand options ambiguousCounterEventStream target (Add 1)-            _ <- shutdownTracerProvider provider Nothing-            result `shouldBe` Right (Left (CommandAmbiguous [0, 1]))-            Right recorded <--                Store.runStoreIO storeHandle $-                    Store.readStreamForward (StreamName "counter-command-ambiguous") (StreamVersion 0) 10-            recorded `shouldBe` Vector.empty-            spans <- traverse captureSpan =<< readIORef spansRef-            case spans of-                [sp] -> textAttr (csAttributes sp) "error.type" `shouldBe` Just "command_ambiguous"-                other -> expectationFailure ("expected one span, got " <> show (length other))--        it "rehydrates prior events before appending a second command event" $ \storeHandle -> do-            let target = stream "counter-command-update" :: Stream CounterEventStream-            Right (Right _) <--                Store.runStoreIO storeHandle $-                    runCommand defaultRunCommandOptions counterEventStream target (Add 2)-            result <--                Store.runStoreIO storeHandle $-                    runCommand defaultRunCommandOptions counterEventStream target (Add 3)-            case result of-                Right (Right commandResult) ->-                    commandResult ^. #streamVersion `shouldBe` StreamVersion 2-                other -> expectationFailure ("expected successful second command, got " <> show other)-            Right recorded <--                Store.runStoreIO storeHandle $-                    Store.readStreamForward (StreamName "counter-command-update") (StreamVersion 0) 10-            traverse (decodeRecorded counterCodec) (Vector.toList recorded)-                `shouldBe` Right [CounterAdded 2, CounterAdded 3]--        it "rejects hydration after truncation without a covering snapshot" $ \storeHandle -> do-            let target = stream "counter-truncated-uncovered" :: Stream CounterEventStream-                targetName = StreamName "counter-truncated-uncovered"-            Right (Right _) <--                Store.runStoreIO storeHandle $-                    runCommand defaultRunCommandOptions counterEventStream target (Add 1)-            Right (Right _) <--                Store.runStoreIO storeHandle $-                    runCommand defaultRunCommandOptions counterEventStream target (Add 2)-            Right (Right _) <--                Store.runStoreIO storeHandle $-                    runCommand defaultRunCommandOptions counterEventStream target (Add 3)-            Right (Just _) <--                Store.runStoreIO storeHandle $-                    Store.setStreamTruncateBefore targetName (StreamVersion 3)-            result <--                Store.runStoreIO storeHandle $-                    runCommand defaultRunCommandOptions counterEventStream target (Add 4)-            case result of-                Right (Left (HydrationGapDetected expected observed)) -> do-                    expected `shouldBe` StreamVersion 1-                    observed `shouldBe` StreamVersion 3-                other -> expectationFailure ("expected HydrationGapDetected, got " <> show other)--        it "rejects hydration when truncation lands inside a command batch" $ \storeHandle -> do-            let target = stream "counter-truncated-mid-batch" :: Stream CounterEventStream-                targetName = StreamName "counter-truncated-mid-batch"-            Right (Right _) <--                Store.runStoreIO storeHandle $-                    runCommand defaultRunCommandOptions multiCounterEventStream target (Add 1)-            Right (Just _) <--                Store.runStoreIO storeHandle $-                    Store.setStreamTruncateBefore targetName (StreamVersion 2)-            result <--                Store.runStoreIO storeHandle $-                    runCommand defaultRunCommandOptions multiCounterEventStream target (Add 2)-            case result of-                Right (Left (HydrationGapDetected expected observed)) -> do-                    expected `shouldBe` StreamVersion 1-                    observed `shouldBe` StreamVersion 2-                other -> expectationFailure ("expected HydrationGapDetected, got " <> show other)--        it "hydrates normally after truncation covered by a snapshot" $ \storeHandle -> do-            let target = stream "counter-truncated-covered" :: Stream SnapshotCounterEventStream-                targetName = StreamName "counter-truncated-covered"-            Right (Right _) <--                Store.runStoreIO storeHandle $-                    runCommand defaultRunCommandOptions snapshotCounterEventStream target (Add 1)-            Right (Right _) <--                Store.runStoreIO storeHandle $-                    runCommand defaultRunCommandOptions snapshotCounterEventStream target (Add 2)-            Right (Just _) <--                Store.runStoreIO storeHandle $-                    Store.setStreamTruncateBefore targetName (StreamVersion 2)-            result <--                Store.runStoreIO storeHandle $-                    runCommand defaultRunCommandOptions snapshotCounterEventStream target (Add 3)-            case result of-                Right (Right commandResult) ->-                    commandResult ^. #streamVersion `shouldBe` StreamVersion 3-                other -> expectationFailure ("expected snapshot-covered command success, got " <> show other)--        it "uses caller-supplied event ids for idempotent command batches" $ \storeHandle -> do-            let target = stream "counter-command-event-id" :: Stream CounterEventStream-                supplied = EventId sampleUuid2-                options = defaultRunCommandOptions & #eventIds .~ [supplied]-            result <--                Store.runStoreIO storeHandle $-                    runCommand options counterEventStream target (Add 7)-            case result of-                Right (Right commandResult) ->-                    commandResult ^. #streamVersion `shouldBe` StreamVersion 1-                other -> expectationFailure ("expected successful command, got " <> show other)-            Right recorded <--                Store.runStoreIO storeHandle $-                    Store.readStreamForward (StreamName "counter-command-event-id") (StreamVersion 0) 10-            fmap (^. #eventId) (Vector.toList recorded) `shouldBe` [supplied]--        it "retries an optimistic conflict after rehydrating the winning event" $ \storeHandle -> do-            conflictInserted <- newIORef False-            let target = stream "counter-command-conflict" :: Stream CounterEventStream-                conflictStreamName = StreamName "counter-command-conflict"-                insertConflict = do-                    shouldInsert <- atomicModifyIORef' conflictInserted $ \alreadyInserted ->-                        if alreadyInserted-                            then (True, False)-                            else (True, True)-                    when shouldInsert $ do-                        encoded <- shouldBeRight (encodeForAppend counterCodec (CounterAdded 10))-                        outcome <--                            Store.runStoreIO storeHandle $-                                Store.appendToStream conflictStreamName NoStream [encoded]-                        case outcome of-                            Right _ -> pure ()-                            Left err -> expectationFailure ("failed to insert conflict event: " <> show err)-                options = defaultRunCommandOptions & #beforeAppend .~ insertConflict-            result <--                Store.runStoreIO storeHandle $-                    runCommand options counterEventStream target (Add 2)-            case result of-                Right (Right commandResult) -> do-                    commandResult ^. #streamVersion `shouldBe` StreamVersion 2-                    commandResult ^. #eventsAppended `shouldBe` 1-                other -> expectationFailure ("expected retry to succeed, got " <> show other)-            Right recorded <--                Store.runStoreIO storeHandle $-                    Store.readStreamForward conflictStreamName (StreamVersion 0) 10-            traverse (decodeRecorded counterCodec) (Vector.toList recorded)-                `shouldBe` Right [CounterAdded 10, CounterAdded 2]--        it "reports true retry attempts and command conflict metrics when the retry budget is exhausted" $ \storeHandle -> do-            (exporter, metricsRef) <- inMemoryMetricExporter-            (provider, _env) <--                createMeterProvider-                    emptyMaterializedResources-                    defaultSdkMeterProviderOptions{metricExporter = Just exporter}-            meter <- getMeter provider Telemetry.keiroInstrumentationLibrary-            keiroMetrics <- Telemetry.newKeiroMetrics meter-            let target = stream "counter-command-exhausted-conflict" :: Stream CounterEventStream-                conflictStreamName = StreamName "counter-command-exhausted-conflict"-                insertConflict = do-                    encoded <- shouldBeRight (encodeForAppend counterCodec (CounterAdded 10))-                    outcome <--                        Store.runStoreIO storeHandle $-                            Store.appendToStream conflictStreamName AnyVersion [encoded]-                    case outcome of-                        Right _ -> pure ()-                        Left err -> expectationFailure ("failed to insert conflict event: " <> show err)-                options =-                    defaultRunCommandOptions-                        & #beforeAppend-                        .~ insertConflict-                        & #retryLimit-                        .~ 2-                        & #retryBackoffMicros-                        .~ 0-                        & #metrics-                        ?~ keiroMetrics-            result <--                Store.runStoreIO storeHandle $-                    runCommand options counterEventStream target (Add 2)-            case result of-                Right (Left (RetryExhausted attempts _)) ->-                    attempts `shouldBe` 3-                other -> expectationFailure ("expected exhausted retry budget, got " <> show other)-            _ <- forceFlushMeterProvider provider Nothing-            exported <- readIORef metricsRef-            let scalars = flattenScalarPoints exported-            lookup "keiro.command.conflicts" scalars `shouldBe` Just (IntNumber 3)-            lookup "keiro.command.retries" scalars `shouldBe` Just (IntNumber 2)--        it "records the successful retry attempt on the command span" $ \storeHandle -> do-            (processor, spansRef) <- inMemoryListExporter-            provider <- createTracerProvider [processor] emptyTracerProviderOptions-            conflictInserted <- newIORef False-            let tracer = makeTracer provider "keiro-test" tracerOptions-                target = stream "counter-command-retry-span" :: Stream CounterEventStream-                conflictStreamName = StreamName "counter-command-retry-span"-                insertConflict = do-                    shouldInsert <- atomicModifyIORef' conflictInserted $ \alreadyInserted ->-                        if alreadyInserted-                            then (True, False)-                            else (True, True)-                    when shouldInsert $ do-                        encoded <- shouldBeRight (encodeForAppend counterCodec (CounterAdded 10))-                        outcome <--                            Store.runStoreIO storeHandle $-                                Store.appendToStream conflictStreamName NoStream [encoded]-                        case outcome of-                            Right _ -> pure ()-                            Left err -> expectationFailure ("failed to insert conflict event: " <> show err)-                options =-                    defaultRunCommandOptions-                        & #beforeAppend-                        .~ insertConflict-                        & #retryBackoffMicros-                        .~ 0-                        & #tracer-                        ?~ tracer-            Right (Right _) <--                Store.runStoreIO storeHandle $-                    runCommand options counterEventStream target (Add 2)-            _ <- shutdownTracerProvider provider Nothing-            spans <- traverse captureSpan =<< readIORef spansRef-            case spans of-                [sp] ->-                    case lookupAttribute (csAttributes sp) "keiro.retry.attempt" of-                        Just (AttributeValue (IntAttribute n)) -> n `shouldBe` 2-                        other -> expectationFailure ("expected retry attempt attribute 2, got " <> show other)-                other -> expectationFailure ("expected one span, got " <> show (length other))--        it "counts duplicate deterministic command events" $ \storeHandle -> do-            (exporter, metricsRef) <- inMemoryMetricExporter-            (provider, _env) <--                createMeterProvider-                    emptyMaterializedResources-                    defaultSdkMeterProviderOptions{metricExporter = Just exporter}-            meter <- getMeter provider Telemetry.keiroInstrumentationLibrary-            keiroMetrics <- Telemetry.newKeiroMetrics meter-            let supplied = EventId sampleUuid3-                first = stream "counter-command-duplicate-a" :: Stream CounterEventStream-                second = stream "counter-command-duplicate-b" :: Stream CounterEventStream-                options =-                    defaultRunCommandOptions-                        & #eventIds-                        .~ [supplied]-                        & #metrics-                        ?~ keiroMetrics-            Right (Right _) <--                Store.runStoreIO storeHandle $-                    runCommand options counterEventStream first (Add 1)-            result <--                Store.runStoreIO storeHandle $-                    runCommand options counterEventStream second (Add 2)-            case result of-                Right (Left (StoreFailed Store.DuplicateEvent{})) -> pure ()-                other -> expectationFailure ("expected duplicate event failure, got " <> show other)-            _ <- forceFlushMeterProvider provider Nothing-            exported <- readIORef metricsRef-            lookup "keiro.command.duplicates" (flattenScalarPoints exported) `shouldBe` Just (IntNumber 1)--        it "fails fast when a soft-deleted stream causes a conflict fixpoint" $ \storeHandle -> do-            (exporter, metricsRef) <- inMemoryMetricExporter-            (provider, _env) <--                createMeterProvider-                    emptyMaterializedResources-                    defaultSdkMeterProviderOptions{metricExporter = Just exporter}-            meter <- getMeter provider Telemetry.keiroInstrumentationLibrary-            keiroMetrics <- Telemetry.newKeiroMetrics meter-            let target = stream "counter-command-soft-deleted" :: Stream CounterEventStream-                options =-                    defaultRunCommandOptions-                        & #retryBackoffMicros-                        .~ 0-                        & #metrics-                        ?~ keiroMetrics-            Right (Right _) <--                Store.runStoreIO storeHandle $-                    runCommand options counterEventStream target (Add 1)-            Right (Just _) <--                Store.runStoreIO storeHandle $-                    Store.softDeleteStream (StreamName "counter-command-soft-deleted")-            result <--                Store.runStoreIO storeHandle $-                    runCommand options counterEventStream target (Add 2)-            case result of-                Right (Left (ConflictFixpoint (StreamVersion 0) Store.StreamAlreadyExists{})) -> pure ()-                other -> expectationFailure ("expected conflict fixpoint, got " <> show other)-            _ <- forceFlushMeterProvider provider Nothing-            exported <- readIORef metricsRef-            lookup "keiro.command.conflicts" (flattenScalarPoints exported) `shouldBe` Just (IntNumber 1)--        it "surfaces decode failure during hydration" $ \storeHandle -> do-            Right _ <--                Store.runStoreIO storeHandle $-                    Store.appendToStream-                        (StreamName "counter-command-decode-failure")-                        NoStream-                        [ EventData-                            { eventId = Nothing-                            , eventType = EventType "OtherEvent"-                            , payload = object []-                            , metadata = Just (metadataForOrDie 1 Nothing)-                            , causationId = Nothing-                            , correlationId = Nothing-                            }-                        ]-            let target = stream "counter-command-decode-failure" :: Stream CounterEventStream-            result <--                Store.runStoreIO storeHandle $-                    runCommand defaultRunCommandOptions counterEventStream target (Add 1)-            result-                `shouldBe` Right-                    (Left (HydrationDecodeFailed (UnknownEventType (EventType "OtherEvent") [EventType "CounterAdded", EventType "CounterAudited"])))--        it "surfaces a typed no-inverting-edge hydration failure" $ \storeHandle -> do-            let targetStreamName = StreamName "counter-command-no-inverting-edge"-                target = stream "counter-command-no-inverting-edge" :: Stream CounterEventStream-            appendCounterEvents storeHandle targetStreamName [CounterAudited 7]-            result <--                Store.runStoreIO storeHandle $-                    runCommand defaultRunCommandOptions counterEventStream target (Add 1)-            result-                `shouldBe` Right-                    (Left (HydrationReplayFailed (StreamVersion 1) HydrationNoInvertingEdge))--        it "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)--        it "reads the minimum checkpoint across consumer-group subscription members" $ \storeHandle -> do-            Right () <--                Store.runStoreIO storeHandle $-                    Store.runTransaction $ do-                        Tx.statement ("counter-read-model-sub", 1, 7) upsertSubscriptionCursorMemberStmt-                        Tx.statement ("counter-read-model-sub", 2, 3) upsertSubscriptionCursorMemberStmt-            position <--                Store.runStoreIO storeHandle $-                    readSubscriptionPosition "counter-read-model-sub"-            position `shouldBe` Right (Just (GlobalPosition 3))--        it "Strong returns immediately on an empty log" $ \storeHandle -> do-            Right () <--                Store.runStoreIO storeHandle $-                    initializeRegisteredReadModel counterReadModel initializeCounterReadModelTable-            queryResult <--                Store.runStoreIO storeHandle $-                    runQueryWith Nothing Strong counterReadModel "empty"-            queryResult `shouldBe` Right (Right 0)--        it "Strong returns immediately when the subscription is already at the store head" $ \_ ->-            withFreshResourceStore fixture $ \(storeHandle, StoreRunner runner) -> do-                Right () <--                    Store.runStoreIO storeHandle $-                        initializeRegisteredReadModel counterReadModel initializeCounterReadModelTable-                let target = stream "read-model-strong-at-head" :: Stream CounterEventStream-                Right (Right commandResult) <--                    runner $-                        runCommandWithProjections-                            defaultRunCommandOptions-                            counterEventStream-                            target-                            (Add 5)-                            [counterInlineProjection]-                globalPosition <- case commandResult ^. #globalPosition of-                    Just position -> pure position-                    Nothing -> expectationFailure "expected command global position" *> error "unreachable"-                Right () <--                    Store.runStoreIO storeHandle $-                        Store.runTransaction $-                            Tx.statement ("counter-read-model-sub", globalPositionToInt globalPosition) upsertSubscriptionCursorStmt-                queryResult <--                    Store.runStoreIO storeHandle $-                        runQueryWith Nothing Strong counterReadModel "inline"-                queryResult `shouldBe` Right (Right 5)--        it "Strong blocks until the subscription reaches the store head captured at query start" $ \_ ->-            withFreshResourceStore fixture $ \(storeHandle, StoreRunner runner) -> do-                Right () <--                    Store.runStoreIO storeHandle $-                        initializeRegisteredReadModel counterReadModel initializeCounterReadModelTable-                let target = stream "read-model-strong-blocking" :: Stream CounterEventStream-                Right (Right commandResult) <--                    runner $-                        runCommandWithProjections-                            defaultRunCommandOptions-                            counterEventStream-                            target-                            (Add 6)-                            [counterInlineProjection]-                globalPosition <- case commandResult ^. #globalPosition of-                    Just position -> pure position-                    Nothing -> expectationFailure "expected command global position" *> error "unreachable"-                _ <- forkIO $ do-                    threadDelay 20000-                    advanced <--                        Store.runStoreIO storeHandle $-                            Store.runTransaction $-                                Tx.statement ("counter-read-model-sub", globalPositionToInt globalPosition) upsertSubscriptionCursorStmt-                    case advanced of-                        Right () -> pure ()-                        Left err -> expectationFailure ("failed to advance subscription cursor: " <> show err)-                queryResult <--                    Store.runStoreIO storeHandle $-                        runQueryWith Nothing Strong counterReadModel "inline"-                queryResult `shouldBe` Right (Right 6)--        it "Strong returns when its category is caught up despite another active category" $ \_ ->-            withFreshResourceStore fixture $ \(storeHandle, StoreRunner runner) -> do-                Right () <--                    Store.runStoreIO storeHandle $-                        initializeRegisteredReadModel counterReadModel initializeCounterReadModelTable-                let counterTarget = stream "counter-strong-scope" :: Stream CounterEventStream-                    otherTarget = stream "otherload-1" :: Stream CounterEventStream-                Right (Right counterResult) <--                    runner $-                        runCommandWithProjections-                            defaultRunCommandOptions-                            counterEventStream-                            counterTarget-                            (Add 8)-                            [counterInlineProjection]-                counterPosition <- case counterResult ^. #globalPosition of-                    Just position -> pure position-                    Nothing -> expectationFailure "expected counter global position" *> error "unreachable"-                Right () <--                    Store.runStoreIO storeHandle $-                        Store.runTransaction $-                            Tx.statement-                                ("counter-read-model-sub", globalPositionToInt counterPosition)-                                upsertSubscriptionCursorStmt-                Right (Right _) <--                    Store.runStoreIO storeHandle $-                        runCommand defaultRunCommandOptions counterEventStream otherTarget (Add 1)-                queryResult <--                    Store.runStoreIO storeHandle $-                        runQueryWith Nothing Strong counterCategoryReadModel "inline"-                queryResult `shouldBe` Right (Right 8)--        it "inline projection populates actor and source_event_id from command metadata" $ \_ ->-            withFreshResourceStore fixture $ \(storeHandle, StoreRunner runner) -> do-                Right () <--                    Store.runStoreIO storeHandle $-                        initializeRegisteredReadModel counterReadModel initializeCounterReadModelTable-                let target = stream "read-model-inline-metadata" :: Stream CounterEventStream-                    opts =-                        defaultRunCommandOptions-                            & #metadata-                            ?~ object ["actor" Aeson..= ("agent-7" :: Text)]-                Right (Right _) <--                    runner $-                        runCommandWithProjections opts counterEventStream target (Add 5) [counterInlineProjection]-                Right row <--                    Store.runStoreIO storeHandle $-                        Store.runTransaction (Tx.statement "inline" selectCounterMetaStmt)-                -- selectCounterMetaStmt returns (amount, actor, source_event_id).-                row `shouldSatisfy` \(amount, actor, srcId) ->-                    amount == 5 && actor == Just "agent-7" && isJust srcId--        it "waits for async projection cursor with PositionWait" $ \_ ->-            withFreshResourceStore fixture $ \(storeHandle, StoreRunner runner) -> do-                Right () <--                    Store.runStoreIO storeHandle $-                        initializeRegisteredReadModel counterReadModel initializeCounterReadModelTable-                let target = stream "read-model-position-wait" :: Stream CounterEventStream-                Right (Right commandResult) <--                    runner $-                        runCommandWithProjections-                            defaultRunCommandOptions-                            counterEventStream-                            target-                            (Add 3)-                            [counterInlineProjection]-                globalPosition <- case commandResult ^. #globalPosition of-                    Just position -> pure position-                    Nothing -> expectationFailure "expected command global position" *> error "unreachable"-                Right () <--                    Store.runStoreIO storeHandle $-                        Store.runTransaction $-                            Tx.statement ("counter-read-model-sub", globalPositionToInt globalPosition) upsertSubscriptionCursorStmt-                queryResult <--                    Store.runStoreIO storeHandle $-                        runQueryWith-                            Nothing-                            (PositionWait (fastWaitOptions & #target .~ Just globalPosition))-                            counterReadModel-                            "inline"-                queryResult `shouldBe` Right (Right 3)--        it "times out when PositionWait target is not reached" $ \storeHandle -> do-            Right () <--                Store.runStoreIO storeHandle $-                    initializeRegisteredReadModel counterReadModel initializeCounterReadModelTable-            Right () <--                Store.runStoreIO storeHandle $-                    Store.runTransaction $-                        Tx.statement ("counter-read-model-sub", 1) upsertSubscriptionCursorStmt-            queryResult <--                Store.runStoreIO storeHandle $-                    runQueryWith-                        Nothing-                        (PositionWait (fastWaitOptions & #target .~ Just (GlobalPosition 5)))-                        counterReadModel-                        "timeout"-            queryResult-                `shouldBe` Right-                    (Left (ReadModelWaitTimeout "counter-read-model" (GlobalPosition 5) (GlobalPosition 1)))--        it "does not write the registry row on repeated read-model queries" $ \storeHandle -> do-            Right () <--                Store.runStoreIO storeHandle $-                    initializeRegisteredReadModel counterReadModel initializeCounterReadModelTable-            Right (Right 0) <--                Store.runStoreIO storeHandle $-                    runQuery Nothing counterReadModel "no-churn"-            Right xminBefore <--                Store.runStoreIO storeHandle $-                    Store.runTransaction $-                        Tx.statement "counter-read-model" readModelXminStmt-            Right (Right 0) <--                Store.runStoreIO storeHandle $-                    runQuery Nothing counterReadModel "no-churn"-            Right xminAfter <--                Store.runStoreIO storeHandle $-                    Store.runTransaction $-                        Tx.statement "counter-read-model" readModelXminStmt-            xminAfter `shouldBe` xminBefore--        it "rejects an unregistered model without creating a registry row" $ \storeHandle -> do-            let unregistered :: ReadModel Text Int-                unregistered = counterReadModel & #name .~ ("never-registered" :: Text)-            queryResult <--                Store.runStoreIO storeHandle $-                    runQuery Nothing unregistered "missing"-            queryResult `shouldBe` Right (Left (ReadModelUnregistered "never-registered"))-            found <--                Store.runStoreIO storeHandle $-                    lookupReadModel "never-registered"-            found `shouldBe` Right Nothing--        it "handles concurrent explicit read-model registration" $ \storeHandle -> do-            Right () <--                Store.runStoreIO storeHandle $-                    Store.runTransaction initializeCounterReadModelTable-            resultA <- newEmptyMVar-            resultB <- newEmptyMVar-            _ <--                forkIO $-                    Store.runStoreIO storeHandle (registerReadModelDefinition counterReadModel)-                        >>= putMVar resultA-            _ <--                forkIO $-                    Store.runStoreIO storeHandle (registerReadModelDefinition counterReadModel)-                        >>= putMVar resultB-            first <- takeMVar resultA-            second <- takeMVar resultB-            first `shouldBe` Right ()-            second `shouldBe` Right ()-            queryResult <--                Store.runStoreIO storeHandle $-                    runQuery Nothing counterReadModel "concurrent"-            queryResult `shouldBe` Right (Right 0)--        it "rejects stale read-model schema" $ \storeHandle -> do-            Right () <--                Store.runStoreIO storeHandle $-                    initializeRegisteredReadModel counterReadModel initializeCounterReadModelTable-            Right (Right 0) <--                Store.runStoreIO storeHandle $-                    runQuery Nothing counterReadModel "stale"-            Right () <--                Store.runStoreIO storeHandle $-                    Store.runTransaction $-                        Tx.statement ("counter-read-model", 99) updateReadModelVersionStmt-            queryResult <--                Store.runStoreIO storeHandle $-                    runQuery Nothing counterReadModel "stale"-            queryResult-                `shouldBe` Right-                    (Left (ReadModelStaleSchema "counter-read-model" 1 99 "counter-read-model-v1" "counter-read-model-v1"))--        it "surfaces unknown read-model statuses with the raw status text" $ \storeHandle -> do-            Right () <--                Store.runStoreIO storeHandle $-                    initializeRegisteredReadModel counterReadModel initializeCounterReadModelTable-            Right (Right 0) <--                Store.runStoreIO storeHandle $-                    runQuery Nothing counterReadModel "unknown-status"-            Right () <--                Store.runStoreIO storeHandle $-                    Store.runTransaction $-                        Tx.statement ("counter-read-model", "wedged") updateReadModelStatusStmt-            queryResult <--                Store.runStoreIO storeHandle $-                    runQuery Nothing counterReadModel "unknown-status"-            queryResult-                `shouldBe` Right-                    (Left (ReadModelNotLive "counter-read-model" (UnknownStatus "wedged")))--        it "ignores duplicate async event by source_event_id" $ \storeHandle -> do-            Right () <--                Store.runStoreIO storeHandle $-                    initializeRegisteredReadModel counterReadModel initializeCounterReadModelTable-            let target = stream "read-model-async-idempotent" :: Stream CounterEventStream-            Right (Right _) <--                Store.runStoreIO storeHandle $-                    runCommand defaultRunCommandOptions counterEventStream target (Add 7)-            Right recorded <--                Store.runStoreIO storeHandle $-                    Store.readStreamForward (StreamName "read-model-async-idempotent") (StreamVersion 0) 10-            event <- case Vector.toList recorded of-                [onlyEvent] -> pure onlyEvent-                other -> expectationFailure ("expected one event, got " <> show other) *> error "unreachable"-            Right outcomes <- Store.runStoreIO storeHandle $-                Store.runTransaction $ do-                    first <- applyAsyncProjection counterAsyncProjection event-                    second <- applyAsyncProjection counterAsyncProjection event-                    pure (first, second)-            outcomes `shouldBe` (AsyncApplied, AsyncDuplicate)-            queryResult <--                Store.runStoreIO storeHandle $-                    runQuery Nothing counterReadModel "async-idempotent"-            queryResult `shouldBe` Right (Right 7)--        it "deduplicates async projection application across transactions and reopens after pruning" $ \storeHandle -> do-            Right () <--                Store.runStoreIO storeHandle $-                    Store.runTransaction initializeProjectionDedupCounterTable-            Right _ <--                Store.runStoreIO storeHandle $-                    registerReadModel "projection-dedup-counter-model" 1 "projection-dedup-counter-v1"-            let target = stream "read-model-async-dedup-window" :: Stream CounterEventStream-            Right (Right _) <--                Store.runStoreIO storeHandle $-                    runCommand defaultRunCommandOptions counterEventStream target (Add 7)-            Right recorded <--                Store.runStoreIO storeHandle $-                    Store.readStreamForward (StreamName "read-model-async-dedup-window") (StreamVersion 0) 10-            event <- case Vector.toList recorded of-                [onlyEvent] -> pure onlyEvent-                other -> expectationFailure ("expected one event, got " <> show other) *> error "unreachable"-            let incrementingProjection =-                    AsyncProjection-                        { name = "incrementing-async-projection"-                        , readModelName = "projection-dedup-counter-model"-                        , subscriptionName = "incrementing-async-projection-sub"-                        , applyRecorded = \_ -> Tx.statement () incrementProjectionDedupCounterStmt-                        , idempotencyKey = \recordedEvent -> recordedEvent ^. #eventId-                        }-            Right AsyncApplied <--                Store.runStoreIO storeHandle $-                    Store.runTransaction $-                        applyAsyncProjection incrementingProjection event-            Right AsyncDuplicate <--                Store.runStoreIO storeHandle $-                    Store.runTransaction $-                        applyAsyncProjection incrementingProjection event-            Right countAfterDuplicate <--                Store.runStoreIO storeHandle $-                    Store.runTransaction $-                        Tx.statement () selectProjectionDedupCounterStmt-            countAfterDuplicate `shouldBe` 1-            cutoff <- addUTCTime 1 <$> getCurrentTime-            pruned <- Store.runStoreIO storeHandle $ pruneAsyncProjectionDedupBefore cutoff-            pruned `shouldBe` Right 1-            Right AsyncApplied <--                Store.runStoreIO storeHandle $-                    Store.runTransaction $-                        applyAsyncProjection incrementingProjection event-            Right countAfterPrune <--                Store.runStoreIO storeHandle $-                    Store.runTransaction $-                        Tx.statement () selectProjectionDedupCounterStmt-            countAfterPrune `shouldBe` 2--        it "rebuild repopulates the projection table through the supported workflow" $ \storeHandle -> do-            Right () <--                Store.runStoreIO storeHandle $-                    initializeRegisteredReadModel counterReadModel initializeCounterReadModelTable-            let target = stream "read-model-rebuild-runbook" :: Stream CounterEventStream-            Right (Right _) <--                Store.runStoreIO storeHandle $-                    runCommand defaultRunCommandOptions counterEventStream target (Add 7)-            Right recorded <--                Store.runStoreIO storeHandle $-                    Store.readStreamForward (StreamName "read-model-rebuild-runbook") (StreamVersion 0) 10-            event <- case Vector.toList recorded of-                [onlyEvent] -> pure onlyEvent-                other -> expectationFailure ("expected one event, got " <> show other) *> error "unreachable"-            Right AsyncApplied <--                Store.runStoreIO storeHandle $-                    Store.runTransaction $-                        applyAsyncProjection counterAsyncProjection event-            Right () <--                Store.runStoreIO storeHandle $-                    Store.runTransaction $-                        Tx.statement-                            ( "counter-read-model-sub"-                            , globalPositionToInt (event ^. #globalPosition)-                            )-                            upsertSubscriptionCursorStmt-            beforeRebuild <--                Store.runStoreIO storeHandle $-                    runQuery Nothing counterReadModel "async-idempotent"-            beforeRebuild `shouldBe` Right (Right 7)--            Right rebuilding <--                Store.runStoreIO storeHandle $-                    Rebuild.startRebuild-                        counterReadModel-                        [counterAsyncProjection ^. #name]-                        (GlobalPosition 0)-            rebuilding ^. #status `shouldBe` Rebuilding-            checkpointAfterReset <--                Store.runStoreIO storeHandle $-                    readSubscriptionPosition "counter-read-model-sub"-            checkpointAfterReset `shouldBe` Right (Just (GlobalPosition 0))-            Right AsyncApplied <--                Store.runStoreIO storeHandle $-                    Store.runTransaction $-                        applyAsyncProjectionUnfenced counterAsyncProjection event-            Right (Right live) <--                Store.runStoreIO storeHandle $-                    Rebuild.finishRebuild-                        counterReadModel-                        [counterAsyncProjection ^. #name]-                        (GlobalPosition 0)-            live ^. #status `shouldBe` Live--            afterRebuild <--                Store.runStoreIO storeHandle $-                    runQuery Nothing counterReadModel "async-idempotent"-            afterRebuild `shouldBe` Right (Right 7)--        it "keeps a non-empty-log rebuild offline when replay applies nothing" $ \storeHandle -> do-            Right () <--                Store.runStoreIO storeHandle $-                    initializeRegisteredReadModel counterReadModel initializeCounterReadModelTable-            let target = stream "read-model-rebuild-empty-replay" :: Stream CounterEventStream-            Right (Right _) <--                Store.runStoreIO storeHandle $-                    runCommand defaultRunCommandOptions counterEventStream target (Add 7)-            Right _ <--                Store.runStoreIO storeHandle $-                    Rebuild.startRebuild-                        counterReadModel-                        [counterAsyncProjection ^. #name]-                        (GlobalPosition 0)-            finishResult <--                Store.runStoreIO storeHandle $-                    Rebuild.finishRebuild-                        counterReadModel-                        [counterAsyncProjection ^. #name]-                        (GlobalPosition 0)-            case finishResult of-                Right (Left (Rebuild.RebuildProducedNoApplies modelName headPosition)) -> do-                    modelName `shouldBe` "counter-read-model"-                    headPosition `shouldSatisfy` (> GlobalPosition 0)-                other -> expectationFailure ("expected zero-apply guard, got " <> show other)-            queryResult <--                Store.runStoreIO storeHandle $-                    runQuery Nothing counterReadModel "async-idempotent"-            queryResult-                `shouldBe` Right-                    (Left (ReadModelNotLive "counter-read-model" Rebuilding))--        it "fences live async application while a model is rebuilding" $ \storeHandle -> do-            Right () <--                Store.runStoreIO storeHandle $-                    initializeRegisteredReadModel counterReadModel initializeCounterReadModelTable-            let target = stream "read-model-fenced-apply" :: Stream CounterEventStream-            Right (Right _) <--                Store.runStoreIO storeHandle $-                    runCommand defaultRunCommandOptions counterEventStream target (Add 7)-            Right recorded <--                Store.runStoreIO storeHandle $-                    Store.readStreamForward (StreamName "read-model-fenced-apply") (StreamVersion 0) 10-            event <- case Vector.toList recorded of-                [onlyEvent] -> pure onlyEvent-                other -> expectationFailure ("expected one event, got " <> show other) *> error "unreachable"-            Right _ <--                Store.runStoreIO storeHandle $-                    Rebuild.startRebuild-                        counterReadModel-                        [counterAsyncProjection ^. #name]-                        (GlobalPosition 0)-            outcome <--                Store.runStoreIO storeHandle $-                    Store.runTransaction $-                        applyAsyncProjection counterAsyncProjection event-            outcome `shouldBe` Right AsyncFenced-            Right dedupCount <--                Store.runStoreIO storeHandle $-                    Store.runTransaction $-                        Tx.statement (counterAsyncProjection ^. #name) projectionDedupCountStmt-            dedupCount `shouldBe` 0-            Right amount <--                Store.runStoreIO storeHandle $-                    Store.runTransaction $-                        Tx.statement "async-idempotent" selectCounterReadModelStmt-            amount `shouldBe` 0--        it "keeps a live applier out of the rebuild window and reopens it after promotion" $ \storeHandle -> do-            Right () <--                Store.runStoreIO storeHandle $-                    initializeRegisteredReadModel counterReadModel initializeCounterReadModelTable-            let target = stream "read-model-fence-race" :: Stream CounterEventStream-            Right (Right _) <--                Store.runStoreIO storeHandle $-                    runCommand defaultRunCommandOptions counterEventStream target (Add 7)-            Right recorded <--                Store.runStoreIO storeHandle $-                    Store.readStreamForward (StreamName "read-model-fence-race") (StreamVersion 0) 10-            event <- case Vector.toList recorded of-                [onlyEvent] -> pure onlyEvent-                other -> expectationFailure ("expected one event, got " <> show other) *> error "unreachable"-            enterRebuildWindow <- newEmptyMVar-            liveApplyResult <- newEmptyMVar-            _ <--                forkIO $ do-                    takeMVar enterRebuildWindow-                    Store.runStoreIO-                        storeHandle-                        (Store.runTransaction (applyAsyncProjection counterAsyncProjection event))-                        >>= putMVar liveApplyResult-            Right _ <--                Store.runStoreIO storeHandle $-                    Rebuild.startRebuild-                        counterReadModel-                        [counterAsyncProjection ^. #name]-                        (GlobalPosition 0)-            putMVar enterRebuildWindow ()-            takeMVar liveApplyResult `shouldReturn` Right AsyncFenced--            Right AsyncApplied <--                Store.runStoreIO storeHandle $-                    Store.runTransaction $-                        applyAsyncProjectionUnfenced counterAsyncProjection event-            Right (Right _) <--                Store.runStoreIO storeHandle $-                    Rebuild.finishRebuild-                        counterReadModel-                        [counterAsyncProjection ^. #name]-                        (GlobalPosition 0)-            cutoff <- addUTCTime 1 <$> getCurrentTime-            pruned <- Store.runStoreIO storeHandle $ pruneAsyncProjectionDedupBefore cutoff-            pruned `shouldBe` Right 1-            reapplied <--                Store.runStoreIO storeHandle $-                    Store.runTransaction $-                        applyAsyncProjection counterAsyncProjection event-            reapplied `shouldBe` Right AsyncApplied-            queryResult <--                Store.runStoreIO storeHandle $-                    runQuery Nothing counterReadModel "async-idempotent"-            queryResult `shouldBe` Right (Right 7)--        it "tracks rebuild state transitions" $ \storeHandle -> do-            Right () <--                Store.runStoreIO storeHandle $-                    registerReadModelDefinition counterReadModel-            Right rebuilding <--                Store.runStoreIO storeHandle $-                    Rebuild.rebuild counterReadModel-            rebuilding ^. #status `shouldBe` Rebuilding-            Right live <--                Store.runStoreIO storeHandle $-                    Rebuild.promote counterReadModel-            live ^. #status `shouldBe` Live-            Right abandoned <--                Store.runStoreIO storeHandle $-                    Rebuild.abandonRebuild counterReadModel-            abandoned ^. #status `shouldBe` Abandoned--        it "records projection lag behind the log head" $ \storeHandle -> do-            (exporter, metricsRef) <- inMemoryMetricExporter-            (provider, _env) <--                createMeterProvider-                    emptyMaterializedResources-                    defaultSdkMeterProviderOptions{metricExporter = Just exporter}-            meter <- getMeter provider Telemetry.keiroInstrumentationLibrary-            keiroMetrics <- Telemetry.newKeiroMetrics meter-            Right () <--                Store.runStoreIO storeHandle $-                    initializeRegisteredReadModel counterReadModel initializeCounterReadModelTable-            let target = stream "read-model-lag" :: Stream CounterEventStream-            Right (Right _) <--                Store.runStoreIO storeHandle $-                    runCommand defaultRunCommandOptions counterEventStream target (Add 1)-            Right (Right _) <--                Store.runStoreIO storeHandle $-                    runCommand defaultRunCommandOptions counterEventStream target (Add 1)-            -- The subscription cursor is never advanced, so the read model is behind-            -- the head by every appended event: the lag gauge records that gap.-            Right () <--                Store.runStoreIO storeHandle $-                    recordProjectionLag (Just keiroMetrics) counterAsyncProjection-            _ <- forceFlushMeterProvider provider Nothing-            exported <- readIORef metricsRef-            let scalars = flattenScalarPoints exported-            case lookup "keiro.projection.lag" scalars of-                Just (IntNumber n) -> n `shouldSatisfy` (>= 1)-                other -> expectationFailure ("expected an integer projection lag, got " <> show other)--        it "counts a position-wait timeout in the timeout counter" $ \storeHandle -> do-            (exporter, metricsRef) <- inMemoryMetricExporter-            (provider, _env) <--                createMeterProvider-                    emptyMaterializedResources-                    defaultSdkMeterProviderOptions{metricExporter = Just exporter}-            meter <- getMeter provider Telemetry.keiroInstrumentationLibrary-            keiroMetrics <- Telemetry.newKeiroMetrics meter-            Right () <--                Store.runStoreIO storeHandle $-                    initializeRegisteredReadModel counterReadModel initializeCounterReadModelTable-            Right () <--                Store.runStoreIO storeHandle $-                    Store.runTransaction $-                        Tx.statement ("counter-read-model-sub", 1) upsertSubscriptionCursorStmt-            queryResult <--                Store.runStoreIO storeHandle $-                    runQueryWith-                        (Just keiroMetrics)-                        (PositionWait (fastWaitOptions & #target .~ Just (GlobalPosition 5)))-                        counterReadModel-                        "timeout"-            queryResult-                `shouldBe` Right-                    (Left (ReadModelWaitTimeout "counter-read-model" (GlobalPosition 5) (GlobalPosition 1)))-            _ <- forceFlushMeterProvider provider Nothing-            exported <- readIORef metricsRef-            let scalars = flattenScalarPoints exported-            -- The single give-up bumped the counter exactly once.-            lookup "keiro.projection.wait.timeouts" scalars `shouldBe` Just (IntNumber 1)--    describe "Keiro.ProcessManager" $ around (withFreshResourceStore fixture) $ do-        it "advances manager state, emits a deterministic target command once, and schedules a timer" $ \(_storeHandle, StoreRunner _runner) -> do-            let sourceEvent = recordedFromEventId (EventId sampleUuid) (CounterAdded 9)-            result <--                _runner $-                    runProcessManagerOnce defaultRunCommandOptions counterProcessManager sourceEvent (CounterAdded 9)-            case result of-                Right (Right pmResult) -> do-                    case pmResult ^. #managerResult of-                        PMStateAppended managerResult ->-                            managerResult ^. #streamVersion `shouldBe` StreamVersion 1-                        other -> expectationFailure ("expected appended manager state, got " <> show other)-                    case pmResult ^. #commandResults of-                        [PMCommandAppended commandResult] ->-                            commandResult ^. #eventsAppended `shouldBe` 1-                        other -> expectationFailure ("expected one emitted command, got " <> show other)-                    pmResult ^. #timersScheduled `shouldBe` 1-                other -> expectationFailure ("expected process-manager success, got " <> show other)-            Right managerEvents <--                _runner $-                    Store.readStreamForward (StreamName "pm:counter-order-1") (StreamVersion 0) 10-            Right targetEvents <--                _runner $-                    Store.readStreamForward (StreamName "counter-target-order-1") (StreamVersion 0) 10-            Vector.length managerEvents `shouldBe` 1-            Vector.length targetEvents `shouldBe` 1-            timer <--                _runner $-                    claimDueTimer dueTimerTime-            case timer of-                Right (Just row) -> do-                    row ^. #processManagerName `shouldBe` "counter-pm"-                    row ^. #correlationId `shouldBe` "order-1"-                other -> expectationFailure ("expected scheduled timer row, got " <> show other)--        it "schedules timers when the manager command emits no events" $ \(_storeHandle, StoreRunner _runner) -> do-            let sourceEvent = recordedFromEventId (EventId sampleUuid) (CounterAdded 9)-            result <--                _runner $-                    runProcessManagerOnce defaultRunCommandOptions timerOnlyProcessManager sourceEvent (CounterAdded 9)-            case result of-                Right (Right pmResult) -> do-                    case pmResult ^. #managerResult of-                        PMStateAppended managerResult -> do-                            managerResult ^. #streamVersion `shouldBe` StreamVersion 0-                            managerResult ^. #eventsAppended `shouldBe` 0-                        other -> expectationFailure ("expected no-op manager state, got " <> show other)-                    pmResult ^. #commandResults `shouldBe` []-                    pmResult ^. #timersScheduled `shouldBe` 1-                other -> expectationFailure ("expected process-manager success, got " <> show other)-            dueCount <--                _runner $-                    countDueTimers dueTimerTime-            dueCount `shouldBe` Right 1-            timer <--                _runner $-                    claimDueTimer dueTimerTime-            case timer of-                Right (Just row) -> do-                    row ^. #processManagerName `shouldBe` "timer-only-pm"-                    row ^. #correlationId `shouldBe` "order-1"-                other -> expectationFailure ("expected scheduled timer row, got " <> show other)--        it "treats duplicate input delivery as idempotent state and command dispatch" $ \(_storeHandle, StoreRunner _runner) -> do-            let sourceEvent = recordedFromEventId (EventId sampleUuid2) (CounterAdded 4)-            Right (Right _) <--                _runner $-                    runProcessManagerOnce defaultRunCommandOptions counterProcessManager sourceEvent (CounterAdded 4)-            duplicate <--                _runner $-                    runProcessManagerOnce defaultRunCommandOptions counterProcessManager sourceEvent (CounterAdded 4)-            case duplicate of-                Right (Right pmResult) -> do-                    pmResult ^. #managerResult `shouldSatisfy` \case-                        PMStateDuplicate{} -> True-                        _ -> False-                    pmResult ^. #commandResults `shouldSatisfy` \case-                        [PMCommandDuplicate{}] -> True-                        _ -> False-                other -> expectationFailure ("expected idempotent duplicate handling, got " <> show other)-            Right managerEvents <--                _runner $-                    Store.readStreamForward (StreamName "pm:counter-order-1") (StreamVersion 0) 10-            Right targetEvents <--                _runner $-                    Store.readStreamForward (StreamName "counter-target-order-1") (StreamVersion 0) 10-            Vector.length managerEvents `shouldBe` 1-            Vector.length targetEvents `shouldBe` 1--        it "replays a Kiroku dead letter freshly and deduplicates a second replay" $ \(_storeHandle, StoreRunner _runner) -> do-            let subName = SubscriptionName "counter-pm-replay-fresh"-                replayHandler recorded =-                    case decodeRecorded counterCodec recorded of-                        Left err -> pure (Left (Text.pack (show err)))-                        Right input -> do-                            outcome <--                                runProcessManagerOnce-                                    defaultRunCommandOptions-                                    counterProcessManager-                                    recorded-                                    input-                            pure $-                                case outcome of-                                    Left err -> Left (Text.pack (show err))-                                    Right result -> Right (classifyProcessManagerReplay result)-            source <- deadLetterCounterSource _storeHandle subName (CounterAdded 7)-            Right listed <- _runner (listSubscriptionDeadLetters subName 0)-            Vector.length listed `shouldBe` 1--            Right firstPass <--                _runner $-                    replaySubscriptionDeadLetters subName 0 replayHandler-            firstPass-                `shouldBe` [ ReplayOutcome-                                { replayGlobalPosition = source ^. #globalPosition-                                , replayEventId = source ^. #eventId-                                , replayResult = ReplayedFresh-                                }-                           ]-            processManagerReplayCounts _storeHandle `shouldReturn` (1, 1)--            Right secondPass <--                _runner $-                    replaySubscriptionDeadLetters subName 0 replayHandler-            secondPass-                `shouldBe` [ ReplayOutcome-                                { replayGlobalPosition = source ^. #globalPosition-                                , replayEventId = source ^. #eventId-                                , replayResult = ReplayedDuplicate-                                }-                           ]-            processManagerReplayCounts _storeHandle `shouldReturn` (1, 1)-            Right retained <- _runner (listSubscriptionDeadLetters subName 0)-            Vector.length retained `shouldBe` 1--        it "reports an already-processed Kiroku dead letter without appending" $ \(_storeHandle, StoreRunner _runner) -> do-            let subName = SubscriptionName "counter-pm-replay-duplicate"-                replayHandler recorded =-                    case decodeRecorded counterCodec recorded of-                        Left err -> pure (Left (Text.pack (show err)))-                        Right input -> do-                            outcome <--                                runProcessManagerOnce-                                    defaultRunCommandOptions-                                    counterProcessManager-                                    recorded-                                    input-                            pure $-                                case outcome of-                                    Left err -> Left (Text.pack (show err))-                                    Right result -> Right (classifyProcessManagerReplay result)-            source <- deadLetterCounterSource _storeHandle subName (CounterAdded 8)-            Right (Right _) <--                _runner $-                    runProcessManagerOnce-                        defaultRunCommandOptions-                        counterProcessManager-                        source-                        (CounterAdded 8)-            countsBefore <- processManagerReplayCounts _storeHandle--            Right outcomes <--                _runner $-                    replaySubscriptionDeadLetters subName 0 replayHandler-            outcomes-                `shouldBe` [ ReplayOutcome-                                { replayGlobalPosition = source ^. #globalPosition-                                , replayEventId = source ^. #eventId-                                , replayResult = ReplayedDuplicate-                                }-                           ]-            processManagerReplayCounts _storeHandle `shouldReturn` countsBefore--        it "keeps multiple workflow process managers isolated by configured streams and categories" $ \(_storeHandle, StoreRunner _runner) -> do-            let sourceEvent = recordedFromEventId (EventId sampleUuid) (CounterAdded 6)-                fulfillmentManager =-                    workflowProcessManager-                        "fulfillment-pm"-                        "pm:fulfillment"-                        "fulfillment-target-order-1"-                billingManager =-                    workflowProcessManager-                        "billing-pm"-                        "pm:billing"-                        "billing-target-order-1"-            fulfillmentResult <--                _runner $-                    runProcessManagerOnce defaultRunCommandOptions fulfillmentManager sourceEvent (CounterAdded 6)-            billingResult <--                _runner $-                    runProcessManagerOnce defaultRunCommandOptions billingManager sourceEvent (CounterAdded 6)-            assertWorkflowProcessManagerAppended fulfillmentResult-            assertWorkflowProcessManagerAppended billingResult--            Right fulfillmentManagerEvents <--                _runner $-                    Store.readStreamForward (StreamName "pm:fulfillment-order-1") (StreamVersion 0) 10-            Right billingManagerEvents <--                _runner $-                    Store.readStreamForward (StreamName "pm:billing-order-1") (StreamVersion 0) 10-            Right fulfillmentTargetEvents <--                _runner $-                    Store.readStreamForward (StreamName "fulfillment-target-order-1") (StreamVersion 0) 10-            Right billingTargetEvents <--                _runner $-                    Store.readStreamForward (StreamName "billing-target-order-1") (StreamVersion 0) 10-            Vector.length fulfillmentManagerEvents `shouldBe` 1-            Vector.length billingManagerEvents `shouldBe` 1-            Vector.length fulfillmentTargetEvents `shouldBe` 1-            Vector.length billingTargetEvents `shouldBe` 1--            Right fulfillmentCategoryEvents <--                _runner $-                    Store.readCategory (CategoryName "pm:fulfillment") (GlobalPosition 0) 10-            Right billingCategoryEvents <--                _runner $-                    Store.readCategory (CategoryName "pm:billing") (GlobalPosition 0) 10-            Right sharedPmCategoryEvents <--                _runner $-                    Store.readCategory (CategoryName "pm") (GlobalPosition 0) 10-            Right sharedPmNamespaceEvents <--                _runner $-                    Store.readCategory (CategoryName "pm:") (GlobalPosition 0) 10-            Vector.length fulfillmentCategoryEvents `shouldBe` 1-            Vector.length billingCategoryEvents `shouldBe` 1-            sharedPmCategoryEvents `shouldBe` Vector.empty-            sharedPmNamespaceEvents `shouldBe` Vector.empty--        it "worker finalizes AckOk through the ack handle on success" $ \(_storeHandle, StoreRunner _runner) -> do-            decisionsRef <- newIORef []-            let sourceEvent = recordedFromEventId (EventId sampleUuid) (CounterAdded 9)-                messages = [(sourceEvent, CounterAdded 9)]-                adapter = inMemoryAdapter decisionsRef messages-            Right () <--                _runner $-                    runProcessManagerWorker defaultRunCommandOptions counterProcessManager adapter Just-            decisions <- readIORef decisionsRef-            decisions `shouldBe` [AckOk]--        it "worker halts instead of acking when a target dispatch is rejected" $ \(_storeHandle, StoreRunner _runner) -> do-            decisionsRef <- newIORef []-            let sourceEvent = recordedFromEventId (EventId sampleUuid) (CounterAdded 9)-                messages = [(sourceEvent, CounterAdded 9)]-                adapter = inMemoryAdapter decisionsRef messages-                rejectingPm =-                    (counterProcessManager :: ProcessManager CounterEvent (HsPred '[] CounterCommand) '[] CounterState CounterCommand CounterEvent (HsPred '[] CounterCommand) '[] CounterState CounterCommand CounterEvent)-                        { targetEventStream = rejectingEventStream-                        }-            Right () <--                _runner $-                    runProcessManagerWorker defaultRunCommandOptions rejectingPm adapter Just-            decisions <- readIORef decisionsRef-            decisions `shouldSatisfy` \case-                [AckHalt (HaltFatal _)] -> True-                _ -> False-            Right targetEvents <--                _runner $-                    Store.readStreamForward (StreamName "counter-target-order-1") (StreamVersion 0) 10-            Right managerEvents <--                _runner $-                    Store.readStreamForward (StreamName "pm:counter-order-1") (StreamVersion 0) 10-            Vector.length targetEvents `shouldBe` 0-            Vector.length managerEvents `shouldBe` 1--        it "dead-letters a rejected dispatch and continues to the next event" $ \(_storeHandle, StoreRunner _runner) -> do-            (exporter, metricsRef) <- inMemoryMetricExporter-            (provider, _env) <--                createMeterProvider-                    emptyMaterializedResources-                    defaultSdkMeterProviderOptions{metricExporter = Just exporter}-            meter <- getMeter provider Telemetry.keiroInstrumentationLibrary-            keiroMetrics <- Telemetry.newKeiroMetrics meter-            decisionsRef <- newIORef []-            let first = recordedFromEventId (EventId sampleUuid) (CounterAdded 9)-                second = recordedFromEventId (EventId sampleUuid2) (CounterAdded 1)-                messages = [(first, CounterAdded 9), (second, CounterAdded 1)]-                adapter = inMemoryAdapter decisionsRef messages-                policyPm =-                    (counterProcessManager :: ProcessManager CounterEvent (HsPred '[] CounterCommand) '[] CounterState CounterCommand CounterEvent (HsPred '[] CounterCommand) '[] CounterState CounterCommand CounterEvent)-                        { targetEventStream = rejectNineEventStream-                        }-                workerOptions =-                    defaultWorkerOptions-                        & #rejectedCommandPolicy-                        .~ RejectedDeadLetter-                        & #metrics-                        ?~ keiroMetrics-            Right () <--                _runner $-                    runProcessManagerWorkerWith workerOptions defaultRunCommandOptions policyPm adapter Just-            readIORef decisionsRef `shouldReturn` [AckOk, AckOk]-            Right deadLetters <- _runner (listDispatchDeadLetters "counter-pm")-            case deadLetters of-                [row] -> do-                    row ^. #dispatcherKind `shouldBe` DispatcherProcessManager-                    row ^. #correlationId `shouldBe` "order-1"-                    row ^. #sourceEventId `shouldBe` EventId sampleUuid-                    row ^. #emitIndex `shouldBe` 0-                    row ^. #targetStreamName `shouldBe` StreamName "counter-target-order-1"-                    row ^. #errorClass `shouldBe` "command_rejected"-                    row ^. #attemptCount `shouldBe` 1-                other -> expectationFailure ("expected one rejected dispatch dead letter, got " <> show other)-            Right targetEvents <--                _runner $-                    Store.readStreamForward (StreamName "counter-target-order-1") (StreamVersion 0) 10-            Right managerEvents <--                _runner $-                    Store.readStreamForward (StreamName "pm:counter-order-1") (StreamVersion 0) 10-            Vector.length targetEvents `shouldBe` 1-            Vector.length managerEvents `shouldBe` 2-            _ <- forceFlushMeterProvider provider Nothing-            exported <- readIORef metricsRef-            lookup "keiro.dispatch.deadlettered" (flattenScalarPoints exported) `shouldBe` Just (IntNumber 1)--        it "skips a rejected dispatch without writing a dead-letter row" $ \(_storeHandle, StoreRunner _runner) -> do-            (exporter, metricsRef) <- inMemoryMetricExporter-            (provider, _env) <--                createMeterProvider-                    emptyMaterializedResources-                    defaultSdkMeterProviderOptions{metricExporter = Just exporter}-            meter <- getMeter provider Telemetry.keiroInstrumentationLibrary-            keiroMetrics <- Telemetry.newKeiroMetrics meter-            decisionsRef <- newIORef []-            let sourceEvent = recordedFromEventId (EventId sampleUuid) (CounterAdded 9)-                adapter = inMemoryAdapter decisionsRef [(sourceEvent, CounterAdded 9)]-                rejectingPm =-                    (counterProcessManager :: ProcessManager CounterEvent (HsPred '[] CounterCommand) '[] CounterState CounterCommand CounterEvent (HsPred '[] CounterCommand) '[] CounterState CounterCommand CounterEvent)-                        { targetEventStream = rejectingEventStream-                        }-                workerOptions =-                    defaultWorkerOptions-                        & #rejectedCommandPolicy-                        .~ RejectedSkip-                        & #metrics-                        ?~ keiroMetrics-            Right () <--                _runner $-                    runProcessManagerWorkerWith workerOptions defaultRunCommandOptions rejectingPm adapter Just-            readIORef decisionsRef `shouldReturn` [AckOk]-            Right deadLetters <- _runner (listDispatchDeadLetters "counter-pm")-            deadLetters `shouldBe` []-            _ <- forceFlushMeterProvider provider Nothing-            exported <- readIORef metricsRef-            lookup "keiro.dispatch.deadlettered" (flattenScalarPoints exported) `shouldBe` Just (IntNumber 1)--        it "dead-letters a manager-state rejection at emit index minus one" $ \(_storeHandle, StoreRunner _runner) -> do-            decisionsRef <- newIORef []-            let sourceEvent = recordedFromEventId (EventId sampleUuid) (CounterAdded 9)-                adapter = inMemoryAdapter decisionsRef [(sourceEvent, CounterAdded 9)]-                rejectingManager =-                    (counterProcessManager :: ProcessManager CounterEvent (HsPred '[] CounterCommand) '[] CounterState CounterCommand CounterEvent (HsPred '[] CounterCommand) '[] CounterState CounterCommand CounterEvent)-                        { eventStream = rejectingEventStream-                        }-                workerOptions = defaultWorkerOptions & #rejectedCommandPolicy .~ RejectedDeadLetter-            Right () <--                _runner $-                    runProcessManagerWorkerWith workerOptions defaultRunCommandOptions rejectingManager adapter Just-            readIORef decisionsRef `shouldReturn` [AckOk]-            Right deadLetters <- _runner (listDispatchDeadLetters "counter-pm")-            case deadLetters of-                [row] -> do-                    row ^. #emitIndex `shouldBe` (-1)-                    row ^. #targetStreamName `shouldBe` StreamName "pm:counter-order-1"-                    row ^. #errorClass `shouldBe` "command_rejected"-                other -> expectationFailure ("expected one manager-state dead letter, got " <> show other)-            Right managerEvents <--                _runner $-                    Store.readStreamForward (StreamName "pm:counter-order-1") (StreamVersion 0) 10-            managerEvents `shouldBe` Vector.empty--        it "keeps rejected-dispatch dead letters idempotent on source redelivery" $ \(_storeHandle, StoreRunner _runner) -> do-            decisionsRef <- newIORef []-            let sourceEvent = recordedFromEventId (EventId sampleUuid) (CounterAdded 9)-                adapter = inMemoryAdapter decisionsRef [(sourceEvent, CounterAdded 9), (sourceEvent, CounterAdded 9)]-                rejectingPm =-                    (counterProcessManager :: ProcessManager CounterEvent (HsPred '[] CounterCommand) '[] CounterState CounterCommand CounterEvent (HsPred '[] CounterCommand) '[] CounterState CounterCommand CounterEvent)-                        { targetEventStream = rejectingEventStream-                        }-                workerOptions = defaultWorkerOptions & #rejectedCommandPolicy .~ RejectedDeadLetter-            Right () <--                _runner $-                    runProcessManagerWorkerWith workerOptions defaultRunCommandOptions rejectingPm adapter Just-            readIORef decisionsRef `shouldReturn` [AckOk, AckOk]-            Right deadLetters <- _runner (listDispatchDeadLetters "counter-pm")-            Prelude.length deadLetters `shouldBe` 1--        it "records dispatch failures through worker metrics" $ \(_storeHandle, StoreRunner _runner) -> do-            (exporter, metricsRef) <- inMemoryMetricExporter-            (provider, _env) <--                createMeterProvider-                    emptyMaterializedResources-                    defaultSdkMeterProviderOptions{metricExporter = Just exporter}-            meter <- getMeter provider Telemetry.keiroInstrumentationLibrary-            keiroMetrics <- Telemetry.newKeiroMetrics meter-            decisionsRef <- newIORef []-            let sourceEvent = recordedFromEventId (EventId sampleUuid) (CounterAdded 9)-                messages = [(sourceEvent, CounterAdded 9)]-                adapter = inMemoryAdapter decisionsRef messages-                rejectingPm =-                    (counterProcessManager :: ProcessManager CounterEvent (HsPred '[] CounterCommand) '[] CounterState CounterCommand CounterEvent (HsPred '[] CounterCommand) '[] CounterState CounterCommand CounterEvent)-                        { targetEventStream = rejectingEventStream-                        }-                workerOptions = defaultWorkerOptions & #metrics ?~ keiroMetrics-            Right () <--                _runner $-                    runProcessManagerWorkerWith workerOptions defaultRunCommandOptions rejectingPm adapter Just-            _ <- forceFlushMeterProvider provider Nothing-            exported <- readIORef metricsRef-            lookup "keiro.dispatch.failed" (flattenScalarPoints exported) `shouldBe` Just (IntNumber 1)--        it "classifies transient store failures as retry and deterministic command failures as halt" $ \(_storeHandle, StoreRunner _runner) -> do-            isRejectionClass CommandRejected `shouldBe` True-            isRejectionClass (CommandAmbiguous [0, 1]) `shouldBe` True-            isRejectionClass (EncodeFailed (NonObjectCallerMetadata Aeson.Null)) `shouldBe` False-            ackForCommandError (RetryDelay 5) (StoreFailed (Store.ConnectionLost "boom"))-                `shouldBe` AckRetry (RetryDelay 5)-            ackForCommandError (RetryDelay 5) CommandRejected `shouldSatisfy` \case-                AckHalt (HaltFatal _) -> True-                _ -> False-            ackForCommandError (RetryDelay 5) (CommandAmbiguous [0, 1]) `shouldSatisfy` \case-                AckHalt (HaltFatal _) -> True-                _ -> False--        it "worker applies poison-message policy on decode failure" $ \(_storeHandle, StoreRunner _runner) -> do-            let badMessages = ["not-decodable" :: Text]-            defaultDecisions <- newIORef []-            Right () <--                _runner $-                    runProcessManagerWorker-                        defaultRunCommandOptions-                        counterProcessManager-                        (inMemoryAdapter defaultDecisions badMessages)-                        (const Nothing)-            defaultObserved <- readIORef defaultDecisions-            defaultObserved `shouldSatisfy` \case-                [AckHalt (HaltFatal _)] -> True-                _ -> False--            skippedRef <- newIORef []-            skipDecisions <- newIORef []-            let skipOptions =-                    defaultWorkerOptions-                        & #poisonPolicy-                        .~ PoisonSkip (\env -> liftIO (modifyIORef' skippedRef (<> [env ^. #payload])))-            Right () <--                _runner $-                    runProcessManagerWorkerWith-                        skipOptions-                        defaultRunCommandOptions-                        counterProcessManager-                        (inMemoryAdapter skipDecisions badMessages)-                        (const Nothing)-            readIORef skipDecisions `shouldReturn` [AckOk]-            readIORef skippedRef `shouldReturn` badMessages--            deadLetterDecisions <- newIORef []-            deadLetterRef <- newIORef []-            let deadLetterOptions =-                    defaultWorkerOptions-                        & #poisonPolicy-                        .~ PoisonDeadLetter (\env -> liftIO (modifyIORef' deadLetterRef (<> [env ^. #payload])))-            Right () <--                _runner $-                    runProcessManagerWorkerWith-                        deadLetterOptions-                        defaultRunCommandOptions-                        counterProcessManager-                        (inMemoryAdapter deadLetterDecisions badMessages)-                        (const Nothing)-            deadLetterObserved <- readIORef deadLetterDecisions-            deadLetterObserved `shouldSatisfy` \case-                [AckDeadLetter (InvalidPayload _)] -> True-                _ -> False-            readIORef deadLetterRef `shouldReturn` badMessages--        it "folds a concurrent duplicate target dispatch to PMCommandDuplicate" $ \(_storeHandle, StoreRunner _runner) -> do-            insertCount <- newIORef (0 :: Int)-            let sourceEvent = recordedFromEventId (EventId sampleUuid) (CounterAdded 9)-                commandId = deterministicCommandId "counter-pm" "order-1" (sourceEvent ^. #eventId) 0-                targetStreamName = StreamName "counter-target-order-1"-                insertConcurrentTarget = do-                    callNo <- atomicModifyIORef' insertCount (\n -> (n + 1, n))-                    when (callNo == 1) $ appendCounterEventWithId _storeHandle targetStreamName commandId (CounterAdded 9)-                options =-                    defaultRunCommandOptions-                        & #beforeAppend-                        .~ insertConcurrentTarget-                        & #retryBackoffMicros-                        .~ 0-            result <--                _runner $-                    runProcessManagerOnce options counterProcessManager sourceEvent (CounterAdded 9)-            case result of-                Right (Right pmResult) ->-                    pmResult ^. #commandResults `shouldSatisfy` \case-                        [PMCommandDuplicate duplicateId] -> duplicateId == commandId-                        _ -> False-                other -> expectationFailure ("expected duplicate target dispatch fold, got " <> show other)-            Right targetEvents <--                _runner $-                    Store.readStreamForward targetStreamName (StreamVersion 0) 10-            Vector.length targetEvents `shouldBe` 1--        it "folds a concurrent duplicate manager-state append to PMStateDuplicate" $ \(_storeHandle, StoreRunner _runner) -> do-            insertCount <- newIORef (0 :: Int)-            let sourceEvent = recordedFromEventId (EventId sampleUuid) (CounterAdded 9)-                managerId = deterministicCommandId "counter-pm" "order-1" (sourceEvent ^. #eventId) (-1)-                managerStreamName = StreamName "pm:counter-order-1"-                insertConcurrentManager = do-                    callNo <- atomicModifyIORef' insertCount (\n -> (n + 1, n))-                    when (callNo == 0) $ appendCounterEventWithId _storeHandle managerStreamName managerId (CounterAdded 9)-                options =-                    defaultRunCommandOptions-                        & #beforeAppend-                        .~ insertConcurrentManager-                        & #retryBackoffMicros-                        .~ 0-            result <--                _runner $-                    runProcessManagerOnce options counterProcessManager sourceEvent (CounterAdded 9)-            case result of-                Right (Right pmResult) -> do-                    pmResult ^. #managerResult `shouldSatisfy` \case-                        PMStateDuplicate duplicateId -> duplicateId == managerId-                        _ -> False-                    pmResult ^. #commandResults `shouldSatisfy` \case-                        [PMCommandAppended{}] -> True-                        _ -> False-                other -> expectationFailure ("expected duplicate manager-state fold, got " <> show other)--    describe "Keiro.ProcessManager duplicate confirmation" $ around (withFreshResourceStore fixture) $ do-        it "rejects a duplicate report carrying a different id" $ \(_storeHandle, StoreRunner _runner) -> do-            let targetStreamName = StreamName "duplicate-confirmation-mismatch"-                ourId = EventId sampleUuid-                otherId = EventId sampleUuid2-            appendCounterEventWithId _storeHandle targetStreamName otherId (CounterAdded 1)-            outcome <--                _runner $-                    confirmBenignDuplicate-                        targetStreamName-                        ourId-                        (StoreFailed (Store.DuplicateEvent (Just otherId)))-            outcome `shouldBe` Right False--        it "rejects a matching id that exists only in another stream" $ \(_storeHandle, StoreRunner _runner) -> do-            let targetStreamName = StreamName "duplicate-confirmation-target"-                otherStreamName = StreamName "duplicate-confirmation-other"-                ourId = EventId sampleUuid-                targetEventId = EventId sampleUuid2-            appendCounterEventWithId _storeHandle targetStreamName targetEventId (CounterAdded 1)-            appendCounterEventWithId _storeHandle otherStreamName ourId (CounterAdded 1)-            outcome <--                _runner $-                    confirmBenignDuplicate-                        targetStreamName-                        ourId-                        (StoreFailed (Store.DuplicateEvent (Just ourId)))-            outcome `shouldBe` Right False--        it "confirms matching and id-less duplicate reports when the id is in the target stream" $ \(_storeHandle, StoreRunner _runner) -> do-            let targetStreamName = StreamName "duplicate-confirmation-present"-                ourId = EventId sampleUuid-            appendCounterEventWithId _storeHandle targetStreamName ourId (CounterAdded 1)-            matchingOutcome <--                _runner $-                    confirmBenignDuplicate-                        targetStreamName-                        ourId-                        (StoreFailed (Store.DuplicateEvent (Just ourId)))-            missingDetailOutcome <--                _runner $-                    confirmBenignDuplicate-                        targetStreamName-                        ourId-                        (StoreFailed (Store.DuplicateEvent Nothing))-            matchingOutcome `shouldBe` Right True-            missingDetailOutcome `shouldBe` Right True--        it "rejects non-duplicate command failures" $ \(_storeHandle, StoreRunner _runner) -> do-            let targetStreamName = StreamName "duplicate-confirmation-non-duplicate"-                ourId = EventId sampleUuid-            appendCounterEventWithId _storeHandle targetStreamName ourId (CounterAdded 1)-            outcome <--                _runner $-                    confirmBenignDuplicate-                        targetStreamName-                        ourId-                        (StoreFailed (Store.ConnectionLost "boom"))-            outcome `shouldBe` Right False--    describe "Keiro.ProcessManager snapshots" $ around (withFreshResourceStore fixture) $ do-        it "writes a snapshot of the manager state stream after the policy threshold" $ \(_storeHandle, StoreRunner _runner) -> do-            -- Two distinct source events, both correlating to "order-1", drive the one-            -- manager instance to manager-stream version 2, which Every 2 snapshots.-            let sourceA = recordedFromEventId (EventId sampleUuid) (CounterAdded 2)-                sourceB = recordedFromEventId (EventId sampleUuid2) (CounterAdded 3)-            Right (Right _) <--                _runner $-                    runProcessManagerOnce defaultRunCommandOptions pmSnapshotProcessManager sourceA (CounterAdded 2)-            Right (Right _) <--                _runner $-                    runProcessManagerOnce defaultRunCommandOptions pmSnapshotProcessManager sourceB (CounterAdded 3)-            Right managerEvents <--                _runner $-                    Store.readStreamForward (StreamName "pm:counter-snap-order-1") (StreamVersion 0) 10-            Vector.length managerEvents `shouldBe` 2-            Right snapshotVersion <--                _runner $-                    Store.runTransaction $-                        Tx.statement "pm:counter-snap-order-1" snapshotVersionForStreamStmt-            snapshotVersion `shouldBe` Just (StreamVersion 2)--        it "hydrates the manager from its snapshot and replays only the tail" $ \(_storeHandle, StoreRunner _runner) -> do-            -- After the threshold snapshot exists, a third reaction should land on top of-            -- the snapshot at version 3 rather than replaying from version 0.-            let sourceA = recordedFromEventId (EventId sampleUuid) (CounterAdded 2)-                sourceB = recordedFromEventId (EventId sampleUuid2) (CounterAdded 3)-                sourceC = recordedFromEventId (EventId sampleUuid3) (CounterAdded 4)-            Right (Right _) <--                _runner $-                    runProcessManagerOnce defaultRunCommandOptions pmSnapshotProcessManager sourceA (CounterAdded 2)-            Right (Right _) <--                _runner $-                    runProcessManagerOnce defaultRunCommandOptions pmSnapshotProcessManager sourceB (CounterAdded 3)-            -- Confirm the snapshot is present before the tail-replay reaction.-            Right snapshotVersion <--                _runner $-                    Store.runTransaction $-                        Tx.statement "pm:counter-snap-order-1" snapshotVersionForStreamStmt-            snapshotVersion `shouldBe` Just (StreamVersion 2)-            result <--                _runner $-                    runProcessManagerOnce defaultRunCommandOptions pmSnapshotProcessManager sourceC (CounterAdded 4)-            case result of-                Right (Right pmResult) ->-                    case pmResult ^. #managerResult of-                        PMStateAppended managerResult ->-                            managerResult ^. #streamVersion `shouldBe` StreamVersion 3-                        other -> expectationFailure ("expected appended manager state, got " <> show other)-                other -> expectationFailure ("expected snapshot-assisted PM reaction, got " <> show other)--    describe "Keiro.Router" $ around (withFreshResourceStore fixture) $ do-        it "encodes colon-bearing and non-ASCII id components without collisions" $ \(_storeHandle, StoreRunner _runner) -> do-            let sourceEventId = EventId sampleUuid-                colonLeft =-                    deterministicRouterCommandId-                        "router:a"-                        "key"-                        sourceEventId-                        (StreamName "target")-                        0-                colonRight =-                    deterministicRouterCommandId-                        "router"-                        "a:key"-                        sourceEventId-                        (StreamName "target")-                        0-                unicodeLeft =-                    deterministicRouterCommandId-                        "router"-                        "key"-                        sourceEventId-                        (StreamName ("target-" <> Text.singleton '\x101'))-                        0-                unicodeRight =-                    deterministicRouterCommandId-                        "router"-                        "key"-                        sourceEventId-                        (StreamName ("target-" <> Text.singleton '\x201'))-                        0-            colonLeft `shouldNotBe` colonRight-            unicodeLeft `shouldNotBe` unicodeRight--        it "resolves targets effectfully and fans out one command per target" $ \(_storeHandle, StoreRunner _runner) -> do-            Right () <--                _runner $-                    initializeRegisteredReadModel routerTargetsReadModel initializeRouterTargetsTable-            Right () <- _runner $-                Store.runTransaction $ do-                    Tx.statement ("g1", "router-target-a") insertRouterTargetStmt-                    Tx.statement ("g1", "router-target-b") insertRouterTargetStmt-                    Tx.statement ("g1", "router-target-c") insertRouterTargetStmt-            let sourceEvent = recordedFromEventId (EventId sampleUuid) (CounterAdded 1)-            Right (RouterResult rs1) <--                _runner $-                    runRouterOnce defaultRunCommandOptions demoRouter sourceEvent (RouteGroup "g1")-            length rs1 `shouldBe` 3-            rs1 `shouldSatisfy` all isAppended-            -- Data-dependence is load-bearing: an unseeded group resolves to no-            -- targets, so the count tracks the read model, not a fixed list.-            Right (RouterResult rsEmpty) <--                _runner $-                    runRouterOnce defaultRunCommandOptions demoRouter sourceEvent (RouteGroup "no-such-group")-            length rsEmpty `shouldBe` 0-            -- Each resolved target stream received exactly one command.-            Right targetA <--                _runner $-                    Store.readStreamForward (StreamName "router-target-a") (StreamVersion 0) 10-            Right targetB <--                _runner $-                    Store.readStreamForward (StreamName "router-target-b") (StreamVersion 0) 10-            Right targetC <--                _runner $-                    Store.readStreamForward (StreamName "router-target-c") (StreamVersion 0) 10-            Vector.length targetA `shouldBe` 1-            Vector.length targetB `shouldBe` 1-            Vector.length targetC `shouldBe` 1--        it "reports every dispatch as a duplicate on replay, writing no new events" $ \(_storeHandle, StoreRunner _runner) -> do-            Right () <--                _runner $-                    initializeRegisteredReadModel routerTargetsReadModel initializeRouterTargetsTable-            Right () <- _runner $-                Store.runTransaction $ do-                    Tx.statement ("g1", "router-target-a") insertRouterTargetStmt-                    Tx.statement ("g1", "router-target-b") insertRouterTargetStmt-                    Tx.statement ("g1", "router-target-c") insertRouterTargetStmt-            let sourceEvent = recordedFromEventId (EventId sampleUuid) (CounterAdded 1)-            Right (RouterResult rs1) <--                _runner $-                    runRouterOnce defaultRunCommandOptions demoRouter sourceEvent (RouteGroup "g1")-            rs1 `shouldSatisfy` all isAppended-            Right (RouterResult rs2) <--                _runner $-                    runRouterOnce defaultRunCommandOptions demoRouter sourceEvent (RouteGroup "g1")-            length rs2 `shouldBe` 3-            rs2 `shouldSatisfy` all isDuplicate-            -- Replay added nothing: each target stream still holds exactly one event.-            Right targetA <--                _runner $-                    Store.readStreamForward (StreamName "router-target-a") (StreamVersion 0) 10-            Right targetB <--                _runner $-                    Store.readStreamForward (StreamName "router-target-b") (StreamVersion 0) 10-            Right targetC <--                _runner $-                    Store.readStreamForward (StreamName "router-target-c") (StreamVersion 0) 10-            Vector.length targetA `shouldBe` 1-            Vector.length targetB `shouldBe` 1-            Vector.length targetC `shouldBe` 1--        it "dedups by target identity when a redelivered resolve reorders targets after a partial dispatch" $ \(_storeHandle, StoreRunner _runner) -> do-            attemptsRef <- newIORef (0 :: Int)-            let sourceEvent = recordedFromEventId (EventId sampleUuid) (CounterAdded 1)-                router = unstableRouter attemptsRef $ \case-                    0 -> ["swap-a"]-                    _ -> ["swap-b", "swap-a"]-            Right (RouterResult firstAttempt) <--                _runner $-                    runRouterOnce defaultRunCommandOptions router sourceEvent (RouteGroup "g1")-            firstAttempt `shouldSatisfy` all isAppended-            Right (RouterResult secondAttempt) <--                _runner $-                    runRouterOnce defaultRunCommandOptions router sourceEvent (RouteGroup "g1")-            secondAttempt `shouldSatisfy` \case-                [swapB, swapA] -> isAppended swapB && isDuplicate swapA-                _ -> False-            Right swapAEvents <--                _runner $-                    Store.readStreamForward (StreamName "swap-a") (StreamVersion 0) 10-            Right swapBEvents <--                _runner $-                    Store.readStreamForward (StreamName "swap-b") (StreamVersion 0) 10-            Vector.length swapAEvents `shouldBe` 1-            Vector.length swapBEvents `shouldBe` 1--        it "dispatches a target added by resolve drift instead of misreading it as a duplicate" $ \(_storeHandle, StoreRunner _runner) -> do-            attemptsRef <- newIORef (0 :: Int)-            let sourceEvent = recordedFromEventId (EventId sampleUuid) (CounterAdded 1)-                router = unstableRouter attemptsRef $ \case-                    0 -> ["growth-a", "growth-b"]-                    _ -> ["growth-a", "growth-c"]-            Right (RouterResult firstAttempt) <--                _runner $-                    runRouterOnce defaultRunCommandOptions router sourceEvent (RouteGroup "g1")-            firstAttempt `shouldSatisfy` all isAppended-            Right (RouterResult secondAttempt) <--                _runner $-                    runRouterOnce defaultRunCommandOptions router sourceEvent (RouteGroup "g1")-            secondAttempt `shouldSatisfy` \case-                [growthA, growthC] -> isDuplicate growthA && isAppended growthC-                _ -> False-            Right growthAEvents <--                _runner $-                    Store.readStreamForward (StreamName "growth-a") (StreamVersion 0) 10-            Right growthBEvents <--                _runner $-                    Store.readStreamForward (StreamName "growth-b") (StreamVersion 0) 10-            Right growthCEvents <--                _runner $-                    Store.readStreamForward (StreamName "growth-c") (StreamVersion 0) 10-            Vector.length growthAEvents `shouldBe` 1-            Vector.length growthBEvents `shouldBe` 1-            Vector.length growthCEvents `shouldBe` 1--        it "keeps full-completion order swaps idempotent" $ \(_storeHandle, StoreRunner _runner) -> do-            attemptsRef <- newIORef (0 :: Int)-            let sourceEvent = recordedFromEventId (EventId sampleUuid) (CounterAdded 1)-                router = unstableRouter attemptsRef $ \case-                    0 -> ["order-a", "order-b"]-                    _ -> ["order-b", "order-a"]-            Right (RouterResult firstAttempt) <--                _runner $-                    runRouterOnce defaultRunCommandOptions router sourceEvent (RouteGroup "g1")-            firstAttempt `shouldSatisfy` all isAppended-            Right (RouterResult secondAttempt) <--                _runner $-                    runRouterOnce defaultRunCommandOptions router sourceEvent (RouteGroup "g1")-            secondAttempt `shouldSatisfy` all isDuplicate-            Right orderAEvents <--                _runner $-                    Store.readStreamForward (StreamName "order-a") (StreamVersion 0) 10-            Right orderBEvents <--                _runner $-                    Store.readStreamForward (StreamName "order-b") (StreamVersion 0) 10-            Vector.length orderAEvents `shouldBe` 1-            Vector.length orderBEvents `shouldBe` 1--        it "keeps dispatches to targets dropped by a later resolve attempt" $ \(_storeHandle, StoreRunner _runner) -> do-            attemptsRef <- newIORef (0 :: Int)-            let sourceEvent = recordedFromEventId (EventId sampleUuid) (CounterAdded 1)-                router = unstableRouter attemptsRef $ \case-                    0 -> ["drop-a", "drop-b"]-                    _ -> ["drop-b"]-            Right (RouterResult firstAttempt) <--                _runner $-                    runRouterOnce defaultRunCommandOptions router sourceEvent (RouteGroup "g1")-            firstAttempt `shouldSatisfy` all isAppended-            Right (RouterResult secondAttempt) <--                _runner $-                    runRouterOnce defaultRunCommandOptions router sourceEvent (RouteGroup "g1")-            secondAttempt `shouldSatisfy` \case-                [dropB] -> isDuplicate dropB-                _ -> False-            -- Resolve is authoritative per attempt. Across redeliveries, the-            -- dispatched set is the union of each attempt's resolved targets.-            Right dropAEvents <--                _runner $-                    Store.readStreamForward (StreamName "drop-a") (StreamVersion 0) 10-            Right dropBEvents <--                _runner $-                    Store.readStreamForward (StreamName "drop-b") (StreamVersion 0) 10-            Vector.length dropAEvents `shouldBe` 1-            Vector.length dropBEvents `shouldBe` 1--        it "keeps repeated commands to one target distinct within a resolve batch" $ \(_storeHandle, StoreRunner _runner) -> do-            attemptsRef <- newIORef (0 :: Int)-            let sourceEvent = recordedFromEventId (EventId sampleUuid) (CounterAdded 1)-                router = unstableRouter attemptsRef (const ["twin", "twin"])-            Right (RouterResult firstAttempt) <--                _runner $-                    runRouterOnce defaultRunCommandOptions router sourceEvent (RouteGroup "g1")-            firstAttempt `shouldSatisfy` all isAppended-            Right twinEventsAfterFirstAttempt <--                _runner $-                    Store.readStreamForward (StreamName "twin") (StreamVersion 0) 10-            Vector.length twinEventsAfterFirstAttempt `shouldBe` 2-            Right (RouterResult secondAttempt) <--                _runner $-                    runRouterOnce defaultRunCommandOptions router sourceEvent (RouteGroup "g1")-            secondAttempt `shouldSatisfy` all isDuplicate-            Right twinEventsAfterSecondAttempt <--                _runner $-                    Store.readStreamForward (StreamName "twin") (StreamVersion 0) 10-            Vector.length twinEventsAfterSecondAttempt `shouldBe` 2--        it "drains an adapter, dispatching one command per resolved target for every message" $ \(_storeHandle, StoreRunner _runner) -> do-            Right () <--                _runner $-                    initializeRegisteredReadModel routerTargetsReadModel initializeRouterTargetsTable-            Right () <- _runner $-                Store.runTransaction $ do-                    Tx.statement ("g1", "worker-a") insertRouterTargetStmt-                    Tx.statement ("g1", "worker-b") insertRouterTargetStmt-                    Tx.statement ("g2", "worker-c") insertRouterTargetStmt-            decisionsRef <- newIORef []-            let sourceEvent1 = recordedFromEventId (EventId sampleUuid) (CounterAdded 1)-                sourceEvent2 = recordedFromEventId (EventId sampleUuid2) (CounterAdded 1)-                messages =-                    [ (sourceEvent1, RouteGroup "g1")-                    , (sourceEvent2, RouteGroup "g2")-                    ]-                adapter = inMemoryAdapter decisionsRef messages-            Right () <--                _runner $-                    runRouterWorker defaultRunCommandOptions demoRouter adapter Just-            decisions <- readIORef decisionsRef-            decisions `shouldBe` [AckOk, AckOk]-            Right wa <--                _runner $-                    Store.readStreamForward (StreamName "worker-a") (StreamVersion 0) 10-            Right wb <--                _runner $-                    Store.readStreamForward (StreamName "worker-b") (StreamVersion 0) 10-            Right wc <--                _runner $-                    Store.readStreamForward (StreamName "worker-c") (StreamVersion 0) 10-            Vector.length wa `shouldBe` 1-            Vector.length wb `shouldBe` 1-            Vector.length wc `shouldBe` 1--        it "finalizes AckHalt rather than AckOk when a dispatched command fails" $ \(_storeHandle, StoreRunner _runner) -> do-            decisionsRef <- newIORef []-            let sourceEvent = recordedFromEventId (EventId sampleUuid) (CounterAdded 1)-                messages = [(sourceEvent, RouteGroup "g1")]-                adapter = inMemoryAdapter decisionsRef messages-            Right () <--                _runner $-                    runRouterWorker defaultRunCommandOptions failingRouter adapter Just-            decisions <- readIORef decisionsRef-            decisions `shouldSatisfy` \case-                [AckHalt (HaltFatal _)] -> True-                _ -> False--        it "dead-letters a rejected router dispatch and acknowledges the source event" $ \(_storeHandle, StoreRunner _runner) -> do-            decisionsRef <- newIORef []-            let sourceEvent = recordedFromEventId (EventId sampleUuid) (CounterAdded 1)-                adapter = inMemoryAdapter decisionsRef [(sourceEvent, RouteGroup "g1")]-                workerOptions = defaultWorkerOptions & #rejectedCommandPolicy .~ RejectedDeadLetter-            Right () <--                _runner $-                    runRouterWorkerWith workerOptions defaultRunCommandOptions failingRouter adapter Just-            readIORef decisionsRef `shouldReturn` [AckOk]-            Right deadLetters <- _runner (listDispatchDeadLetters "failing-router")-            case deadLetters of-                [row] -> do-                    row ^. #dispatcherKind `shouldBe` DispatcherRouter-                    row ^. #correlationId `shouldBe` "g1"-                    row ^. #targetStreamName `shouldBe` StreamName "failing-target"-                    row ^. #errorClass `shouldBe` "command_rejected"-                other -> expectationFailure ("expected one router dead letter, got " <> show other)--        it "finalizes AckRetry for a transient thrown resolver error and continues" $ \(_storeHandle, StoreRunner _runner) -> do-            Right () <--                _runner $-                    initializeRegisteredReadModel routerTargetsReadModel initializeRouterTargetsTable-            Right () <--                _runner $-                    Store.runTransaction (Tx.statement ("g2", "worker-after-retry") insertRouterTargetStmt)-            decisionsRef <- newIORef []-            attemptsRef <- newIORef (0 :: Int)-            let sourceEvent1 = recordedFromEventId (EventId sampleUuid) (CounterAdded 1)-                sourceEvent2 = recordedFromEventId (EventId sampleUuid2) (CounterAdded 1)-                messages = [(sourceEvent1, RouteGroup "g1"), (sourceEvent2, RouteGroup "g2")]-                adapter = inMemoryAdapter decisionsRef messages-                flakyRouter ::-                    (IOE :> es, Store :> es, Error Store.StoreError :> es) =>-                    Router RouteGroup (HsPred '[] CounterCommand) '[] CounterState CounterCommand CounterEvent es-                flakyRouter =-                    Router-                        { name = "flaky-router"-                        , key = \(RouteGroup g) -> g-                        , resolve = \(RouteGroup g) -> do-                            attempt <- liftIO (atomicModifyIORef' attemptsRef (\n -> (n + 1, n)))-                            if attempt == 0-                                then throwError (Store.ConnectionLost "injected")-                                else do-                                    result <- runQuery Nothing routerTargetsReadModel g-                                    pure $ case result of-                                        Right targetIds ->-                                            [ PMCommand{target = stream targetId, command = Add 1}-                                            | targetId <- targetIds-                                            ]-                                        Left _ -> []-                        , targetEventStream = counterEventStream-                        , targetProjections = const []-                        }-            Right () <--                _runner $-                    runRouterWorker defaultRunCommandOptions flakyRouter adapter Just-            decisions <- readIORef decisionsRef-            decisions `shouldSatisfy` \case-                [AckRetry{}, AckOk] -> True-                _ -> False--        it "finalizes AckHalt for a deterministic thrown resolver error" $ \(_storeHandle, StoreRunner _runner) -> do-            decisionsRef <- newIORef []-            let sourceEvent = recordedFromEventId (EventId sampleUuid) (CounterAdded 1)-                messages = [(sourceEvent, RouteGroup "g1")]-                adapter = inMemoryAdapter decisionsRef messages-                failingResolveRouter ::-                    (Error Store.StoreError :> es) =>-                    Router RouteGroup (HsPred '[] CounterCommand) '[] CounterState CounterCommand CounterEvent es-                failingResolveRouter =-                    Router-                        { name = "failing-resolve-router"-                        , key = \(RouteGroup g) -> g-                        , resolve = \_ -> throwError (Store.UnexpectedServerError "XX000" "boom")-                        , targetEventStream = counterEventStream-                        , targetProjections = const []-                        }-            Right () <--                _runner $-                    runRouterWorker defaultRunCommandOptions failingResolveRouter adapter Just-            decisions <- readIORef decisionsRef-            decisions `shouldSatisfy` \case-                [AckHalt (HaltFatal _)] -> True-                _ -> False--        it "folds a concurrent duplicate router dispatch to PMCommandDuplicate" $ \(_storeHandle, StoreRunner _runner) -> do-            Right () <--                _runner $-                    initializeRegisteredReadModel routerTargetsReadModel initializeRouterTargetsTable-            Right () <--                _runner $-                    Store.runTransaction (Tx.statement ("g1", "router-duplicate-target") insertRouterTargetStmt)-            insertCount <- newIORef (0 :: Int)-            let sourceEvent = recordedFromEventId (EventId sampleUuid) (CounterAdded 1)-                targetStreamName = StreamName "router-duplicate-target"-                commandId =-                    deterministicRouterCommandId-                        "demo-router"-                        "g1"-                        (sourceEvent ^. #eventId)-                        targetStreamName-                        0-                insertConcurrentTarget = do-                    callNo <- atomicModifyIORef' insertCount (\n -> (n + 1, n))-                    when (callNo == 0) $ appendCounterEventWithId _storeHandle targetStreamName commandId (CounterAdded 1)-                options =-                    defaultRunCommandOptions-                        & #beforeAppend-                        .~ insertConcurrentTarget-                        & #retryBackoffMicros-                        .~ 0-            result <--                _runner $-                    runRouterOnce options demoRouter sourceEvent (RouteGroup "g1")-            case result of-                Right (RouterResult [PMCommandDuplicate duplicateId]) ->-                    duplicateId `shouldBe` commandId-                other -> expectationFailure ("expected duplicate router dispatch fold, got " <> show other)-            Right targetEvents <--                _runner $-                    Store.readStreamForward targetStreamName (StreamVersion 0) 10-            Vector.length targetEvents `shouldBe` 1--        it "dedups a pre-upgrade positional router dispatch during the transition" $ \(_storeHandle, StoreRunner _runner) -> do-            Right () <--                _runner $-                    initializeRegisteredReadModel routerTargetsReadModel initializeRouterTargetsTable-            Right () <--                _runner $-                    Store.runTransaction (Tx.statement ("g1", "transition-target") insertRouterTargetStmt)-            let sourceEvent = recordedFromEventId (EventId sampleUuid) (CounterAdded 1)-                legacyId = deterministicCommandId "demo-router" "g1" (sourceEvent ^. #eventId) 0-                targetStreamName = StreamName "transition-target"-            appendCounterEventWithId _storeHandle targetStreamName legacyId (CounterAdded 1)-            result <--                _runner $-                    runRouterOnce defaultRunCommandOptions demoRouter sourceEvent (RouteGroup "g1")-            case result of-                Right (RouterResult [PMCommandDuplicate duplicateId]) ->-                    duplicateId `shouldBe` legacyId-                other -> expectationFailure ("expected transition duplicate, got " <> show other)-            Right targetEvents <--                _runner $-                    Store.readStreamForward targetStreamName (StreamVersion 0) 10-            Vector.length targetEvents `shouldBe` 1--    describe "Keiro.Timer" $ around (withFreshStore fixture) $ do-        it "validates worker options before startup" $ \_storeHandle -> do-            shouldBeRight_ (mkTimerWorkerOptions defaultTimerWorkerOptions)-            mkTimerWorkerOptions (defaultTimerWorkerOptions & #maxAttempts ?~ (-1))-                `shouldBeLeft` InvalidTimerMaxAttempts (-1)-            mkTimerWorkerOptions (defaultTimerWorkerOptions & #requeueStuckAfter ?~ 0)-                `shouldBeLeft` InvalidTimerRequeueStuckAfter 0--        it "claims a due timer, fires a command, and marks it complete once" $ \storeHandle -> do-            Right () <--                Store.runStoreIO storeHandle $-                    Store.runTransaction $-                        scheduleTimerTx counterTimerRequest-            let firedEventId = EventId sampleUuid2-            workerResult <- Store.runStoreIO storeHandle $-                runTimerWorker Nothing dueTimerTime $ \_ -> do-                    fired <--                        runCommand-                            (defaultRunCommandOptions & #eventIds .~ [firedEventId])-                            counterEventStream-                            (stream "timer-target")-                            (Add 11)-                    case fired of-                        Right _ -> pure (Just firedEventId)-                        Left err -> liftIO (expectationFailure ("expected timer command to fire, got " <> show err)) *> pure Nothing-            case workerResult of-                Right (Just timer) ->-                    timer ^. #status `shouldBe` Firing-                other -> expectationFailure ("expected fired timer, got " <> show other)-            secondWorkerResult <--                Store.runStoreIO storeHandle $-                    runTimerWorker Nothing dueTimerTime (\_ -> pure (Just firedEventId))-            secondWorkerResult `shouldBe` Right Nothing-            Right targetEvents <--                Store.runStoreIO storeHandle $-                    Store.readStreamForward (StreamName "timer-target") (StreamVersion 0) 10-            fmap (^. #eventId) (Vector.toList targetEvents) `shouldBe` [firedEventId]--        it "records timer backlog, fire lag, attempts, and stuck count" $ \storeHandle -> do-            (exporter, metricsRef) <- inMemoryMetricExporter-            (provider, _env) <--                createMeterProvider-                    emptyMaterializedResources-                    defaultSdkMeterProviderOptions{metricExporter = Just exporter}-            meter <- getMeter provider Telemetry.keiroInstrumentationLibrary-            keiroMetrics <- Telemetry.newKeiroMetrics meter-            Right () <--                Store.runStoreIO storeHandle $-                    Store.runTransaction $-                        scheduleTimerTx counterTimerRequest-            let firedEventId = EventId sampleUuid2-            workerResult <--                Store.runStoreIO storeHandle $-                    runTimerWorker (Just keiroMetrics) dueTimerTime (\_ -> pure (Just firedEventId))-            case workerResult of-                Right (Just _) -> pure ()-                other -> expectationFailure ("expected a fired timer, got " <> show other)-            _ <- forceFlushMeterProvider provider Nothing-            exported <- readIORef metricsRef-            let scalars = flattenScalarPoints exported-                hists = flattenHistogramPoints exported-            -- One scheduled+due row at the start of the pass: backlog gauge holds 1.-            lookup "keiro.timer.backlog" scalars `shouldBe` Just (IntNumber 1)-            -- Nothing was stranded in 'firing' before this pass: stuck gauge holds 0.-            lookup "keiro.timer.stuck" scalars `shouldBe` Just (IntNumber 0)-            -- The claimed timer was due exactly at 'now' and is on its first attempt:-            -- one fire.lag observation of 0 ms and one attempts observation of 1.-            [(c, s) | (n, c, s) <- hists, n == "keiro.timer.fire.lag"] `shouldBe` [(1, 0.0)]-            [(c, s) | (n, c, s) <- hists, n == "keiro.timer.attempts"] `shouldBe` [(1, 1.0)]--        it "finds a firing timer with findStuckTimers and requeues it for re-firing" $ \storeHandle -> do-            Right () <--                Store.runStoreIO storeHandle $-                    Store.runTransaction $-                        scheduleTimerTx counterTimerRequest-            -- Strand it in Firing by claiming without firing.-            claimed <- Store.runStoreIO storeHandle $ claimDueTimer dueTimerTime-            case claimed of-                Right (Just timer) -> timer ^. #status `shouldBe` Firing-                other -> expectationFailure ("expected a claimed timer, got " <> show other)-            -- It surfaces as stuck under the permissive filter.-            Right stuck <--                Store.runStoreIO storeHandle $-                    findStuckTimers dueTimerTime anyStuckTimer-            fmap (^. #timerId) stuck `shouldBe` [counterTimerRequest ^. #timerId]-            -- A bound it does not meet (only one attempt) excludes it.-            Right unmatched <--                Store.runStoreIO storeHandle $-                    findStuckTimers dueTimerTime (StuckTimerFilter Nothing (Just 5))-            unmatched `shouldBe` []-            -- Requeue is idempotent: True the first time, False once it is scheduled.-            requeued <--                Store.runStoreIO storeHandle $-                    requeueStuckTimer (counterTimerRequest ^. #timerId)-            requeued `shouldBe` Right True-            requeuedAgain <--                Store.runStoreIO storeHandle $-                    requeueStuckTimer (counterTimerRequest ^. #timerId)-            requeuedAgain `shouldBe` Right False-            -- The ordinary loop re-claims and fires it exactly once.-            let firedEventId = EventId sampleUuid2-            workerResult <- Store.runStoreIO storeHandle $-                runTimerWorker Nothing dueTimerTime $ \_ -> do-                    fired <--                        runCommand-                            (defaultRunCommandOptions & #eventIds .~ [firedEventId])-                            counterEventStream-                            (stream "timer-target")-                            (Add 7)-                    case fired of-                        Right _ -> pure (Just firedEventId)-                        Left err -> liftIO (expectationFailure ("expected timer command to fire, got " <> show err)) *> pure Nothing-            case workerResult of-                Right (Just timer) ->-                    timer ^. #status `shouldBe` Firing-                other -> expectationFailure ("expected re-fired timer, got " <> show other)-            secondWorkerResult <--                Store.runStoreIO storeHandle $-                    runTimerWorker Nothing dueTimerTime (\_ -> pure (Just firedEventId))-            secondWorkerResult `shouldBe` Right Nothing-            Right targetEvents <--                Store.runStoreIO storeHandle $-                    Store.readStreamForward (StreamName "timer-target") (StreamVersion 0) 10-            fmap (^. #eventId) (Vector.toList targetEvents) `shouldBe` [firedEventId]--        it "re-fires a timer stranded by a crashed worker" $ \storeHandle -> do-            Right () <--                Store.runStoreIO storeHandle $-                    Store.runTransaction $-                        scheduleTimerTx counterTimerRequest-            Right (Just claimed) <- Store.runStoreIO storeHandle $ claimDueTimer dueTimerTime-            claimed ^. #status `shouldBe` Firing-            realNow <- getCurrentTime-            firedRef <- newIORef []-            let futureNow = addUTCTime 400 realNow-                firedEventId = EventId sampleUuid2-            workerResult <--                Store.runStoreIO storeHandle $-                    runTimerWorker Nothing futureNow $ \timer -> do-                        liftIO (modifyIORef' firedRef (<> [timer ^. #timerId]))-                        pure (Just firedEventId)-            case workerResult of-                Right (Just timer) -> timer ^. #timerId `shouldBe` counterTimerRequest ^. #timerId-                other -> expectationFailure ("expected stale timer to be requeued and claimed, got " <> show other)-            firedTimers <- readIORef firedRef-            firedTimers `shouldBe` [counterTimerRequest ^. #timerId]-            Right statusRow <--                Store.runStoreIO storeHandle $-                    Store.runTransaction $-                        Tx.statement sampleUuid timerStatusAndErrorStmt-            statusRow `shouldBe` Just ("fired", Nothing)-            secondWorkerResult <--                Store.runStoreIO storeHandle $-                    runTimerWorker Nothing futureNow (\_ -> pure (Just firedEventId))-            secondWorkerResult `shouldBe` Right Nothing--        it "does not requeue a fresh firing row" $ \storeHandle -> do-            Right () <--                Store.runStoreIO storeHandle $-                    Store.runTransaction $-                        scheduleTimerTx counterTimerRequest-            Right (Just _) <- Store.runStoreIO storeHandle $ claimDueTimer dueTimerTime-            realNow <- getCurrentTime-            firedRef <- newIORef False-            workerResult <--                Store.runStoreIO storeHandle $-                    runTimerWorker Nothing realNow $ \_ -> do-                        liftIO (writeIORef firedRef True)-                        pure (Just (EventId sampleUuid2))-            workerResult `shouldBe` Right Nothing-            didFire <- readIORef firedRef-            didFire `shouldBe` False-            Right statusRow <--                Store.runStoreIO storeHandle $-                    Store.runTransaction $-                        Tx.statement sampleUuid timerStatusAndErrorStmt-            statusRow `shouldBe` Just ("firing", Nothing)--        it "requeueStuckAfter = Nothing preserves a stranded firing row" $ \storeHandle -> do-            Right () <--                Store.runStoreIO storeHandle $-                    Store.runTransaction $-                        scheduleTimerTx counterTimerRequest-            Right (Just _) <- Store.runStoreIO storeHandle $ claimDueTimer dueTimerTime-            realNow <- getCurrentTime-            firedRef <- newIORef False-            let opts = defaultTimerWorkerOptions & #requeueStuckAfter .~ Nothing-            workerResult <--                Store.runStoreIO storeHandle $-                    runTimerWorkerWith Nothing opts (addUTCTime 400 realNow) $ \_ -> do-                        liftIO (writeIORef firedRef True)-                        pure (Just (EventId sampleUuid2))-            workerResult `shouldBe` Right Nothing-            didFire <- readIORef firedRef-            didFire `shouldBe` False-            Right statusRow <--                Store.runStoreIO storeHandle $-                    Store.runTransaction $-                        Tx.statement sampleUuid timerStatusAndErrorStmt-            statusRow `shouldBe` Just ("firing", Nothing)--        it "does not claim a cancelled timer" $ \storeHandle -> do-            Right () <--                Store.runStoreIO storeHandle $-                    Store.runTransaction $-                        scheduleTimerTx counterTimerRequest-            cancelled <--                Store.runStoreIO storeHandle $-                    cancelTimer (counterTimerRequest ^. #timerId)-            cancelled `shouldBe` Right True-            claimed <- Store.runStoreIO storeHandle $ claimDueTimer dueTimerTime-            claimed `shouldBe` Right Nothing-            cancelledAgain <--                Store.runStoreIO storeHandle $-                    cancelTimer (counterTimerRequest ^. #timerId)-            cancelledAgain `shouldBe` Right False--        it "dead-letters a timer that exceeds the attempt ceiling and never reclaims it" $ \storeHandle -> do-            Right () <--                Store.runStoreIO storeHandle $-                    Store.runTransaction $-                        scheduleTimerTx counterTimerRequest-            firedRef <- newIORef False-            let firedEventId = EventId sampleUuid2-            -- maxAttempts = Just 0: the first claim sets attempts = 1 > 0, so the-            -- worker dead-letters instead of firing.-            result <- Store.runStoreIO storeHandle $-                runTimerWorkerWith Nothing (defaultTimerWorkerOptions & #maxAttempts .~ Just 0) dueTimerTime $ \_ -> do-                    liftIO (writeIORef firedRef True)-                    pure (Just firedEventId)-            case result of-                Right (Just timer) ->-                    timer ^. #status `shouldBe` Firing-                other -> expectationFailure ("expected a claimed timer, got " <> show other)-            -- The fire action never ran.-            didFire <- readIORef firedRef-            didFire `shouldBe` False-            -- The row landed in 'dead' with the expected reason in last_error.-            Right statusRow <--                Store.runStoreIO storeHandle $-                    Store.runTransaction $-                        Tx.statement sampleUuid timerStatusAndErrorStmt-            statusRow `shouldBe` Just ("dead", Just "timer exceeded attempt ceiling of 0")-            -- A dead row is never re-claimed.-            secondWorkerResult <--                Store.runStoreIO storeHandle $-                    runTimerWorker Nothing dueTimerTime (\_ -> pure (Just firedEventId))-            secondWorkerResult `shouldBe` Right Nothing--        it "markTimerFired does not resurrect a dead timer" $ \storeHandle -> do-            Right () <--                Store.runStoreIO storeHandle $-                    Store.runTransaction $-                        scheduleTimerTx counterTimerRequest-            Right (Just _) <- Store.runStoreIO storeHandle $ claimDueTimer dueTimerTime-            deadened <--                Store.runStoreIO storeHandle $-                    deadLetterTimer (counterTimerRequest ^. #timerId) "operator dead-letter"-            deadened `shouldBe` Right True-            marked <--                Store.runStoreIO storeHandle $-                    markTimerFired (counterTimerRequest ^. #timerId) (EventId sampleUuid2)-            marked `shouldBe` Right False-            Right statusRow <--                Store.runStoreIO storeHandle $-                    Store.runTransaction $-                        Tx.statement sampleUuid timerStatusAndErrorStmt-            statusRow `shouldBe` Just ("dead", Just "operator dead-letter")--        it "records a row stranded in Firing in the stuck gauge" $ \storeHandle -> do-            (exporter, metricsRef) <- inMemoryMetricExporter-            (provider, _env) <--                createMeterProvider-                    emptyMaterializedResources-                    defaultSdkMeterProviderOptions{metricExporter = Just exporter}-            meter <- getMeter provider Telemetry.keiroInstrumentationLibrary-            keiroMetrics <- Telemetry.newKeiroMetrics meter-            Right () <--                Store.runStoreIO storeHandle $-                    Store.runTransaction $-                        scheduleTimerTx counterTimerRequest-            -- Strand it in Firing by claiming without firing (a crashed worker).-            Right (Just _) <- Store.runStoreIO storeHandle $ claimDueTimer dueTimerTime-            -- A later pass finds nothing scheduled and due, but sees the stranded row.-            workerResult <--                Store.runStoreIO storeHandle $-                    runTimerWorker (Just keiroMetrics) dueTimerTime (\_ -> pure Nothing)-            workerResult `shouldBe` Right Nothing-            _ <- forceFlushMeterProvider provider Nothing-            exported <- readIORef metricsRef-            let scalars = flattenScalarPoints exported-            -- The one firing row is counted as stuck.-            lookup "keiro.timer.stuck" scalars `shouldBe` Just (IntNumber 1)-            -- It is not 'scheduled', so it does not show up as backlog.-            lookup "keiro.timer.backlog" scalars `shouldBe` Just (IntNumber 0)--    describe "Keiro.Outbox.Kafka" $ do-        it "converts an outbox row to a Kafka producer record" $ do-            let envelope = sampleIntegrationEnvelope-                row = sampleOutboxRow envelope-                record = OutboxKafka.outboxRowToKafkaRecord row-            record ^. #topic `shouldBe` envelope ^. #destination-            record ^. #key `shouldBe` Just "order-123"-            record ^. #payload `shouldBe` envelope ^. #payloadBytes-            -- Headers include identity fields and content type.-            let headers = record ^. #headers-                messageIdHeader = Prelude.lookup "keiro-message-id" headers-            messageIdHeader `shouldBe` Just "018f0f18-17aa-7000-8000-0000000000aa"--        it "drops the partition key when the envelope has no key" $ do-            let envelope = sampleIntegrationEnvelope & #key .~ Nothing-                record = OutboxKafka.integrationEventToKafkaRecord envelope-            record ^. #key `shouldBe` Nothing--    describe "Keiro.Outbox" $ around (withFreshStore fixture) $ do-        it "validates publisher options before startup" $ \_storeHandle -> do-            shouldBeRight_ (mkOutboxPublishOptions defaultPublishOptions)-            mkOutboxPublishOptions (defaultPublishOptions & #batchSize .~ 0)-                `shouldBeLeft` InvalidOutboxBatchSize 0-            mkOutboxPublishOptions (defaultPublishOptions & #maxAttempts .~ 0)-                `shouldBeLeft` InvalidOutboxMaxAttempts 0-            mkOutboxPublishOptions (defaultPublishOptions & #publishingTimeout .~ 0)-                `shouldBeLeft` InvalidOutboxPublishingTimeout 0-            mkOutboxPublishOptions (defaultPublishOptions & #backoff .~ ConstantBackoff (-1))-                `shouldBeLeft` InvalidConstantBackoff (-1)-            mkOutboxPublishOptions-                ( defaultPublishOptions-                    & #backoff-                    .~ ExponentialBackoff-                        ExponentialBackoffOptions-                            { initial = 0-                            , maxDelay = 1-                            , multiplier = 2-                            }-                )-                `shouldBeLeft` InvalidExponentialBackoffInitial 0-            mkOutboxPublishOptions-                ( defaultPublishOptions-                    & #backoff-                    .~ ExponentialBackoff-                        ExponentialBackoffOptions-                            { initial = 1-                            , maxDelay = 10-                            , multiplier = 0.5-                            }-                )-                `shouldBeLeft` InvalidExponentialBackoffMultiplier 0.5-            mkOutboxPublishOptions-                ( defaultPublishOptions-                    & #backoff-                    .~ ExponentialBackoff-                        ExponentialBackoffOptions-                            { initial = 5-                            , maxDelay = 4-                            , multiplier = 2-                            }-                )-                `shouldBeLeft` InvalidExponentialBackoffMaxDelay 5 4--        it "enqueues and looks up an outbox row" $ \storeHandle -> do-            let envelope = sampleIntegrationEnvelope-                oid = OutboxId outboxUuid1-            Right () <--                Store.runStoreIO storeHandle $-                    Store.runTransaction (enqueueIntegrationEventTx oid envelope)-            lookedUp <- Store.runStoreIO storeHandle (lookupOutbox oid)-            case lookedUp of-                Right (Just row) -> do-                    row ^. #outboxId `shouldBe` oid-                    row ^. #status `shouldBe` OutboxPending-                    row ^. #attemptCount `shouldBe` 0-                    row ^. #event . #messageId `shouldBe` envelope ^. #messageId-                    row ^. #event . #destination `shouldBe` envelope ^. #destination-                    row ^. #event . #payloadBytes `shouldBe` envelope ^. #payloadBytes-                other -> expectationFailure ("expected enqueued row, got " <> show other)--        it "claims a pending row, transitions it to publishing, and increments attempt count" $ \storeHandle -> do-            let oid = OutboxId outboxUuid1-            Right () <--                Store.runStoreIO storeHandle $-                    Store.runTransaction (enqueueIntegrationEventTx oid sampleIntegrationEnvelope)-            now <- getCurrentTime-            Right rows <- Store.runStoreIO storeHandle (claimOutboxBatch PerKeyHeadOfLine 10 now)-            case rows of-                [row] -> do-                    row ^. #outboxId `shouldBe` oid-                    row ^. #status `shouldBe` OutboxPublishing-                    row ^. #attemptCount `shouldBe` 1-                other -> expectationFailure ("expected one claimed row, got " <> show other)--        it "claims contiguous per-key runs in one pass" $ \storeHandle -> do-            let keyedRows =-                    [ (outboxIdFromOrdinal 1, sampleIntegrationEnvelope & #messageId .~ "run-a1" & #key .~ Just "A")-                    , (outboxIdFromOrdinal 2, sampleIntegrationEnvelope & #messageId .~ "run-a2" & #key .~ Just "A")-                    , (outboxIdFromOrdinal 3, sampleIntegrationEnvelope & #messageId .~ "run-a3" & #key .~ Just "A")-                    , (outboxIdFromOrdinal 4, sampleIntegrationEnvelope & #messageId .~ "run-a4" & #key .~ Just "A")-                    , (outboxIdFromOrdinal 5, sampleIntegrationEnvelope & #messageId .~ "run-a5" & #key .~ Just "A")-                    , (outboxIdFromOrdinal 6, sampleIntegrationEnvelope & #messageId .~ "run-b1" & #key .~ Just "B")-                    , (outboxIdFromOrdinal 7, sampleIntegrationEnvelope & #messageId .~ "run-b2" & #key .~ Just "B")-                    , (outboxIdFromOrdinal 8, sampleIntegrationEnvelope & #messageId .~ "run-b3" & #key .~ Just "B")-                    ]-            Right () <--                Store.runStoreIO storeHandle $-                    Store.runTransaction $-                        traverse_ (uncurry enqueueIntegrationEventTx) keyedRows-            now <- getCurrentTime-            Right rows <- Store.runStoreIO storeHandle (claimOutboxBatch PerKeyHeadOfLine 10 now)-            fmap (^. #outboxId) rows `shouldBe` fmap fst keyedRows-            fmap (^. #attemptCount) rows `shouldBe` replicate 8 1--        it "does not let a backoff head starve other keys" $ \storeHandle -> do-            let a1Id = outboxIdFromOrdinal 1-                a2Id = outboxIdFromOrdinal 2-                b1Id = outboxIdFromOrdinal 3-                b2Id = outboxIdFromOrdinal 4-                rows =-                    [ (a1Id, sampleIntegrationEnvelope & #messageId .~ "backoff-a1" & #key .~ Just "A")-                    , (a2Id, sampleIntegrationEnvelope & #messageId .~ "backoff-a2" & #key .~ Just "A")-                    , (b1Id, sampleIntegrationEnvelope & #messageId .~ "backoff-b1" & #key .~ Just "B")-                    , (b2Id, sampleIntegrationEnvelope & #messageId .~ "backoff-b2" & #key .~ Just "B")-                    ]-                failA1 row-                    | row ^. #outboxId == a1Id = pure (PublishFailed "wait")-                    | otherwise = pure PublishSucceeded-                opts =-                    defaultPublishOptions-                        & #batchSize-                        .~ 1-                        & #backoff-                        .~ ConstantBackoff 3600-            Right () <--                Store.runStoreIO storeHandle $-                    Store.runTransaction $-                        traverse_ (uncurry enqueueIntegrationEventTx) rows-            Right failedPass <- Store.runStoreIO storeHandle (publishClaimedOutbox (perRow failA1) opts Nothing)-            failedPass ^. #retried `shouldBe` 1-            now <- getCurrentTime-            Right claimed <- Store.runStoreIO storeHandle (claimOutboxBatch PerKeyHeadOfLine 10 now)-            fmap (^. #outboxId) claimed `shouldBe` [b1Id, b2Id]-            Right (Just a2Row) <- Store.runStoreIO storeHandle (lookupOutbox a2Id)-            a2Row ^. #status `shouldBe` OutboxPending--        it "claims contiguous per-source runs in one pass" $ \storeHandle -> do-            let rows =-                    [ (outboxIdFromOrdinal 1, sampleIntegrationEnvelope & #messageId .~ "source-a1" & #key .~ Just "A")-                    , (outboxIdFromOrdinal 2, sampleIntegrationEnvelope & #messageId .~ "source-b1" & #key .~ Just "B")-                    , (outboxIdFromOrdinal 3, sampleIntegrationEnvelope & #messageId .~ "source-a2" & #key .~ Just "A")-                    , (outboxIdFromOrdinal 4, sampleIntegrationEnvelope & #messageId .~ "source-b2" & #key .~ Just "B")-                    ]-            Right () <--                Store.runStoreIO storeHandle $-                    Store.runTransaction $-                        traverse_ (uncurry enqueueIntegrationEventTx) rows-            now <- getCurrentTime-            Right claimed <- Store.runStoreIO storeHandle (claimOutboxBatch PerSourceStream 10 now)-            fmap (^. #outboxId) claimed `shouldBe` fmap fst rows--        it "claims null-keyed rows freely alongside keyed runs" $ \storeHandle -> do-            let rows =-                    [ (outboxIdFromOrdinal 1, sampleIntegrationEnvelope & #messageId .~ "null-1" & #key .~ Nothing)-                    , (outboxIdFromOrdinal 2, sampleIntegrationEnvelope & #messageId .~ "keyed-1" & #key .~ Just "A")-                    , (outboxIdFromOrdinal 3, sampleIntegrationEnvelope & #messageId .~ "null-2" & #key .~ Nothing)-                    , (outboxIdFromOrdinal 4, sampleIntegrationEnvelope & #messageId .~ "keyed-2" & #key .~ Just "A")-                    ]-            Right () <--                Store.runStoreIO storeHandle $-                    Store.runTransaction $-                        traverse_ (uncurry enqueueIntegrationEventTx) rows-            now <- getCurrentTime-            Right claimed <- Store.runStoreIO storeHandle (claimOutboxBatch PerKeyHeadOfLine 10 now)-            fmap (^. #outboxId) claimed `shouldBe` fmap fst rows--        it "does not claim a tail while the previous run is still publishing" $ \storeHandle -> do-            let rows =-                    [ (outboxIdFromOrdinal 1, sampleIntegrationEnvelope & #messageId .~ "publishing-a1" & #key .~ Just "A")-                    , (outboxIdFromOrdinal 2, sampleIntegrationEnvelope & #messageId .~ "publishing-a2" & #key .~ Just "A")-                    , (outboxIdFromOrdinal 3, sampleIntegrationEnvelope & #messageId .~ "publishing-a3" & #key .~ Just "A")-                    ]-            Right () <--                Store.runStoreIO storeHandle $-                    Store.runTransaction $-                        traverse_ (uncurry enqueueIntegrationEventTx) rows-            now <- getCurrentTime-            Right firstClaim <- Store.runStoreIO storeHandle (claimOutboxBatch PerKeyHeadOfLine 10 now)-            fmap (^. #outboxId) firstClaim `shouldBe` fmap fst rows-            Right secondClaim <- Store.runStoreIO storeHandle (claimOutboxBatch PerKeyHeadOfLine 10 now)-            secondClaim `shouldBe` []--        it "marks a claimed row as sent with published_at set" $ \storeHandle -> do-            let oid = OutboxId outboxUuid1-            Right () <--                Store.runStoreIO storeHandle $-                    Store.runTransaction (enqueueIntegrationEventTx oid sampleIntegrationEnvelope)-            now <- getCurrentTime-            Right [_] <- Store.runStoreIO storeHandle (claimOutboxBatch PerKeyHeadOfLine 10 now)-            Right True <- Store.runStoreIO storeHandle (markOutboxSent oid now)-            Right (Just row) <- Store.runStoreIO storeHandle (lookupOutbox oid)-            row ^. #status `shouldBe` OutboxSent-            row ^. #publishedAt `shouldSatisfy` isJust-            row ^. #lastError `shouldBe` Nothing--        it "reclaims a row stranded in publishing by a crashed worker through maintenance" $ \storeHandle -> do-            let oid = OutboxId outboxUuid1-            Right () <--                Store.runStoreIO storeHandle $-                    Store.runTransaction (enqueueIntegrationEventTx oid sampleIntegrationEnvelope)-            now <- getCurrentTime-            let pastNow = addUTCTime (-3600) now-            Right [_] <- Store.runStoreIO storeHandle (claimOutboxBatch PerKeyHeadOfLine 10 now)-            Right () <- Store.runStoreIO storeHandle (backdateOutboxUpdatedAt oid pastNow)-            Right (Just stranded) <- Store.runStoreIO storeHandle (lookupOutbox oid)-            stranded ^. #status `shouldBe` OutboxPublishing-            publishedRef <- newIORef (0 :: Int)-            let publish _ = do-                    liftIO (modifyIORef' publishedRef (+ 1))-                    pure PublishSucceeded-            Right noPublish <- Store.runStoreIO storeHandle (publishClaimedOutbox (perRow publish) defaultPublishOptions Nothing)-            noPublish ^. #claimed `shouldBe` 0-            Right (Just stillStranded) <- Store.runStoreIO storeHandle (lookupOutbox oid)-            stillStranded ^. #status `shouldBe` OutboxPublishing-            Right maintenance <- Store.runStoreIO storeHandle (outboxMaintenancePass defaultMaintenanceOptions Nothing)-            maintenance ^. #requeued `shouldBe` 1-            maintenance ^. #deadLettered `shouldBe` 0-            Right summary <- Store.runStoreIO storeHandle (publishClaimedOutbox (perRow publish) defaultPublishOptions Nothing)-            summary ^. #published `shouldBe` 1-            published <- readIORef publishedRef-            published `shouldBe` 1-            Right (Just row) <- Store.runStoreIO storeHandle (lookupOutbox oid)-            row ^. #status `shouldBe` OutboxSent--        it "head-of-line traffic unwedges after reclaim" $ \storeHandle -> do-            let firstId = OutboxId outboxUuid1-                secondId = OutboxId outboxUuid2-                first = sampleIntegrationEnvelope & #messageId .~ "stuck-first" & #key .~ Just "same-key"-                second = sampleIntegrationEnvelope & #messageId .~ "stuck-second" & #key .~ Just "same-key"-            Right () <--                Store.runStoreIO storeHandle $-                    Store.runTransaction (enqueueIntegrationEventTx firstId first)-            Right () <--                Store.runStoreIO storeHandle $-                    Store.runTransaction (enqueueIntegrationEventTx secondId second)-            now <- getCurrentTime-            let pastNow = addUTCTime (-3600) now-            Right [claimedFirst] <- Store.runStoreIO storeHandle (claimOutboxBatch PerKeyHeadOfLine 1 now)-            claimedFirst ^. #outboxId `shouldBe` firstId-            Right () <- Store.runStoreIO storeHandle (backdateOutboxUpdatedAt firstId pastNow)-            publishedRef <- newIORef []-            let publish row = do-                    liftIO (modifyIORef' publishedRef (<> [row ^. #outboxId]))-                    pure PublishSucceeded-            Right maintenance <- Store.runStoreIO storeHandle (outboxMaintenancePass defaultMaintenanceOptions Nothing)-            maintenance ^. #requeued `shouldBe` 1-            Right firstPass <- Store.runStoreIO storeHandle (publishClaimedOutbox (perRow publish) defaultPublishOptions Nothing)-            firstPass ^. #published `shouldBe` 2-            Right secondPass <- Store.runStoreIO storeHandle (publishClaimedOutbox (perRow publish) defaultPublishOptions Nothing)-            secondPass ^. #published `shouldBe` 0-            published <- readIORef publishedRef-            published `shouldBe` [firstId, secondId]-            Right (Just secondRow) <- Store.runStoreIO storeHandle (lookupOutbox secondId)-            secondRow ^. #status `shouldBe` OutboxSent--        it "does not reclaim a recently claimed row" $ \storeHandle -> do-            let oid = OutboxId outboxUuid1-            Right () <--                Store.runStoreIO storeHandle $-                    Store.runTransaction (enqueueIntegrationEventTx oid sampleIntegrationEnvelope)-            now <- getCurrentTime-            Right [_] <- Store.runStoreIO storeHandle (claimOutboxBatch PerKeyHeadOfLine 10 now)-            publishedRef <- newIORef (0 :: Int)-            let publish _ = do-                    liftIO (modifyIORef' publishedRef (+ 1))-                    pure PublishSucceeded-            Right summary <- Store.runStoreIO storeHandle (publishClaimedOutbox (perRow publish) defaultPublishOptions Nothing)-            summary ^. #claimed `shouldBe` 0-            published <- readIORef publishedRef-            published `shouldBe` 0-            Right (Just row) <- Store.runStoreIO storeHandle (lookupOutbox oid)-            row ^. #status `shouldBe` OutboxPublishing--        it "a throwing batch publish callback fails every row in that publish call" $ \storeHandle -> do-            let throwId = OutboxId outboxUuid1-                okId = OutboxId outboxUuid2-                throwEvent = sampleIntegrationEnvelope & #messageId .~ "throwing-publish" & #key .~ Just "throw-key"-                okEvent = sampleIntegrationEnvelope & #messageId .~ "ok-after-throw" & #key .~ Just "ok-key"-            Right () <--                Store.runStoreIO storeHandle $-                    Store.runTransaction (enqueueIntegrationEventTx throwId throwEvent)-            Right () <--                Store.runStoreIO storeHandle $-                    Store.runTransaction (enqueueIntegrationEventTx okId okEvent)-            let publish row-                    | row ^. #outboxId == throwId = liftIO (throwIO (userError "kafka exploded"))-                    | otherwise = pure PublishSucceeded-            Right summary <--                Store.runStoreIO storeHandle $-                    publishClaimedOutbox (perRow publish) (defaultPublishOptions & #backoff .~ ConstantBackoff 0) Nothing-            summary ^. #retried `shouldBe` 2-            summary ^. #published `shouldBe` 0-            Right (Just throwRow) <- Store.runStoreIO storeHandle (lookupOutbox throwId)-            throwRow ^. #status `shouldBe` OutboxFailed-            throwRow ^. #lastError `shouldSatisfy` maybe False (Text.isInfixOf "kafka exploded")-            Right (Just okRow) <- Store.runStoreIO storeHandle (lookupOutbox okId)-            okRow ^. #status `shouldBe` OutboxFailed-            okRow ^. #lastError `shouldSatisfy` maybe False (Text.isInfixOf "kafka exploded")--        it "a row that exhausts attempts while crash-looping is dead-lettered by maintenance" $ \storeHandle -> do-            let oid = OutboxId outboxUuid1-                opts = defaultMaintenanceOptions & #maxAttempts .~ 1-            Right () <--                Store.runStoreIO storeHandle $-                    Store.runTransaction (enqueueIntegrationEventTx oid sampleIntegrationEnvelope)-            now <- getCurrentTime-            let pastNow = addUTCTime (-3600) now-            Right [_] <- Store.runStoreIO storeHandle (claimOutboxBatch PerKeyHeadOfLine 10 now)-            Right () <- Store.runStoreIO storeHandle (backdateOutboxUpdatedAt oid pastNow)-            Right summary <- Store.runStoreIO storeHandle (outboxMaintenancePass opts Nothing)-            summary ^. #requeued `shouldBe` 0-            summary ^. #deadLettered `shouldBe` 1-            Right (Just row) <- Store.runStoreIO storeHandle (lookupOutbox oid)-            row ^. #status `shouldBe` OutboxDead--        it "markOutboxSent does not resurrect a dead row" $ \storeHandle -> do-            let oid = OutboxId outboxUuid1-                opts = defaultPublishOptions & #maxAttempts .~ 1 & #backoff .~ ConstantBackoff 0-            Right () <--                Store.runStoreIO storeHandle $-                    Store.runTransaction (enqueueIntegrationEventTx oid sampleIntegrationEnvelope)-            let publish _ = pure (PublishFailed "boom")-            Right _ <- Store.runStoreIO storeHandle (publishClaimedOutbox (perRow publish) opts Nothing)-            now <- getCurrentTime-            Right marked <- Store.runStoreIO storeHandle (markOutboxSent oid now)-            marked `shouldBe` False-            Right (Just row) <- Store.runStoreIO storeHandle (lookupOutbox oid)-            row ^. #status `shouldBe` OutboxDead--        it "publishClaimedOutbox marks success and records failures with last_error" $ \storeHandle -> do-            let okId = OutboxId outboxUuid1-                failId = OutboxId outboxUuid2-                okEvent = sampleIntegrationEnvelope-                failEvent =-                    sampleIntegrationEnvelope-                        & #messageId-                        .~ "msg-fail-1"-                        & #key-                        .~ Just "order-789"-            Right () <--                Store.runStoreIO storeHandle $-                    Store.runTransaction (enqueueIntegrationEventTx okId okEvent)-            Right () <--                Store.runStoreIO storeHandle $-                    Store.runTransaction (enqueueIntegrationEventTx failId failEvent)-            let publish row-                    | row ^. #outboxId == okId = pure PublishSucceeded-                    | otherwise = pure (PublishFailed "broker unreachable")-            Right summary <--                Store.runStoreIO storeHandle (publishClaimedOutbox (perRow publish) defaultPublishOptions Nothing)-            summary ^. #claimed `shouldBe` 2-            summary ^. #published `shouldBe` 1-            summary ^. #retried `shouldBe` 1-            summary ^. #dead `shouldBe` 0-            Right (Just okRow) <- Store.runStoreIO storeHandle (lookupOutbox okId)-            okRow ^. #status `shouldBe` OutboxSent-            Right (Just failRow) <- Store.runStoreIO storeHandle (lookupOutbox failId)-            failRow ^. #status `shouldBe` OutboxFailed-            failRow ^. #lastError `shouldBe` Just "broker unreachable"--        it "publishClaimedOutbox hands a same-key run to one batch publish call" $ \storeHandle -> do-            let rows =-                    [ (outboxIdFromOrdinal (fromIntegral i), sampleIntegrationEnvelope & #messageId .~ ("batch-ok-" <> Text.pack (show i)) & #key .~ Just "batch-key")-                    | i <- [1 .. 10 :: Int]-                    ]-            Right () <--                Store.runStoreIO storeHandle $-                    Store.runTransaction $-                        traverse_ (uncurry enqueueIntegrationEventTx) rows-            invocationRef <- newIORef (0 :: Int)-            let publish claimed = do-                    liftIO (modifyIORef' invocationRef (+ 1))-                    pure [(row ^. #outboxId, PublishSucceeded) | row <- claimed]-            Right summary <- Store.runStoreIO storeHandle (publishClaimedOutbox publish defaultPublishOptions Nothing)-            summary ^. #claimed `shouldBe` 10-            summary ^. #published `shouldBe` 10-            invocations <- readIORef invocationRef-            invocations `shouldBe` 1-            for_ (fmap fst rows) $ \oid -> do-                Right (Just row) <- Store.runStoreIO storeHandle (lookupOutbox oid)-                row ^. #status `shouldBe` OutboxSent--        it "publishClaimedOutbox skips the same-key suffix after a mid-run failure" $ \storeHandle -> do-            let row1Id = outboxIdFromOrdinal 1-                row2Id = outboxIdFromOrdinal 2-                row3Id = outboxIdFromOrdinal 3-                row4Id = outboxIdFromOrdinal 4-                row5Id = outboxIdFromOrdinal 5-                ids = [row1Id, row2Id, row3Id, row4Id, row5Id]-                rows =-                    [ (oid, sampleIntegrationEnvelope & #messageId .~ ("batch-fail-" <> Text.pack (show i)) & #key .~ Just "batch-fail-key")-                    | (i, oid) <- zip [1 .. 5 :: Int] ids-                    ]-                publish claimed =-                    pure-                        [ ( row ^. #outboxId-                          , if row ^. #outboxId == row3Id-                                then PublishFailed "pivot failed"-                                else PublishSucceeded-                          )-                        | row <- claimed-                        ]-            Right () <--                Store.runStoreIO storeHandle $-                    Store.runTransaction $-                        traverse_ (uncurry enqueueIntegrationEventTx) rows-            Right summary <--                Store.runStoreIO storeHandle $-                    publishClaimedOutbox publish (defaultPublishOptions & #backoff .~ ConstantBackoff 0) Nothing-            summary ^. #published `shouldBe` 2-            summary ^. #retried `shouldBe` 3-            Right (Just row1) <- Store.runStoreIO storeHandle (lookupOutbox row1Id)-            Right (Just row2) <- Store.runStoreIO storeHandle (lookupOutbox row2Id)-            Right (Just row3) <- Store.runStoreIO storeHandle (lookupOutbox row3Id)-            Right (Just row4) <- Store.runStoreIO storeHandle (lookupOutbox row4Id)-            Right (Just row5) <- Store.runStoreIO storeHandle (lookupOutbox row5Id)-            row1 ^. #status `shouldBe` OutboxSent-            row2 ^. #status `shouldBe` OutboxSent-            row3 ^. #status `shouldBe` OutboxFailed-            row3 ^. #attemptCount `shouldBe` 1-            row3 ^. #lastError `shouldBe` Just "pivot failed"-            row4 ^. #status `shouldBe` OutboxFailed-            row4 ^. #attemptCount `shouldBe` 0-            row4 ^. #lastError `shouldBe` Just "skipped: earlier record for the same key failed"-            row5 ^. #status `shouldBe` OutboxFailed-            row5 ^. #attemptCount `shouldBe` 0--        it "PerSourceStream keeps one source's failure from skipping another source's rows" $ \storeHandle -> do-            let rowA1 = outboxIdFromOrdinal 1-                rowB1 = outboxIdFromOrdinal 2-                rowA2 = outboxIdFromOrdinal 3-                rowB2 = outboxIdFromOrdinal 4-                mkRow oid src msgId =-                    (oid, sampleIntegrationEnvelope & #messageId .~ msgId & #source .~ src & #key .~ Nothing)-                rows =-                    [ mkRow rowA1 "per-source-a" "ps-a1"-                    , mkRow rowB1 "per-source-b" "ps-b1"-                    , mkRow rowA2 "per-source-a" "ps-a2"-                    , mkRow rowB2 "per-source-b" "ps-b2"-                    ]-                publish claimed =-                    pure-                        [ ( row ^. #outboxId-                          , if row ^. #outboxId == rowA2-                                then PublishFailed "source-a pivot failed"-                                else PublishSucceeded-                          )-                        | row <- claimed-                        ]-            Right () <--                Store.runStoreIO storeHandle $-                    Store.runTransaction $-                        traverse_ (uncurry enqueueIntegrationEventTx) rows-            Right summary <--                Store.runStoreIO storeHandle $-                    publishClaimedOutbox publish (defaultPublishOptions & #orderingPolicy .~ PerSourceStream & #backoff .~ ConstantBackoff 0) Nothing-            summary ^. #claimed `shouldBe` 4-            summary ^. #published `shouldBe` 3-            summary ^. #retried `shouldBe` 1-            Right (Just a1) <- Store.runStoreIO storeHandle (lookupOutbox rowA1)-            Right (Just a2) <- Store.runStoreIO storeHandle (lookupOutbox rowA2)-            Right (Just b1) <- Store.runStoreIO storeHandle (lookupOutbox rowB1)-            Right (Just b2) <- Store.runStoreIO storeHandle (lookupOutbox rowB2)-            a1 ^. #status `shouldBe` OutboxSent-            a2 ^. #status `shouldBe` OutboxFailed-            a2 ^. #attemptCount `shouldBe` 1-            a2 ^. #lastError `shouldBe` Just "source-a pivot failed"-            b1 ^. #status `shouldBe` OutboxSent-            b2 ^. #status `shouldBe` OutboxSent--        it "a late failure mark does not clobber a row that already reached a terminal state" $ \storeHandle -> do-            let oid = OutboxId outboxUuid1-            Right () <--                Store.runStoreIO storeHandle $-                    Store.runTransaction (enqueueIntegrationEventTx oid sampleIntegrationEnvelope)-            now <- getCurrentTime-            Right [_] <- Store.runStoreIO storeHandle (claimOutboxBatch PerKeyHeadOfLine 10 now)-            Right True <- Store.runStoreIO storeHandle (markOutboxSent oid now)-            Right _ <--                Store.runStoreIO storeHandle $-                    Store.runTransaction (markOutboxFailedTx oid "late failure from a timed-out worker" 5 60 now)-            Right (Just row) <- Store.runStoreIO storeHandle (lookupOutbox oid)-            row ^. #status `shouldBe` OutboxSent-            row ^. #lastError `shouldBe` Nothing--        it "claims nothing while another transaction holds an uncommitted claim on a key's head" $ \storeHandle -> do-            let headId = outboxIdFromOrdinal 1-                tailId = outboxIdFromOrdinal 2-                rows =-                    [ (headId, sampleIntegrationEnvelope & #messageId .~ "claim-race-1" & #key .~ Just "claim-race-key")-                    , (tailId, sampleIntegrationEnvelope & #messageId .~ "claim-race-2" & #key .~ Just "claim-race-key")-                    ]-                OutboxId headUuid = headId-                holdClaimSql =-                    TE.encodeUtf8 $-                        "UPDATE keiro.keiro_outbox SET status = 'publishing', attempt_count = attempt_count + 1, updated_at = now() WHERE outbox_id = '"-                            <> UUID.toText headUuid-                            <> "'"-            Right () <--                Store.runStoreIO storeHandle $-                    Store.runTransaction $-                        traverse_ (uncurry enqueueIntegrationEventTx) rows-            holderDone <- newEmptyMVar-            _ <- forkIO $ do-                holder <--                    Store.runStoreIO storeHandle $-                        Store.runTransaction $ do-                            Tx.sql holdClaimSql-                            Tx.sql "SELECT pg_sleep(2)"-                putMVar holderDone holder-            -- Let the holder acquire its uncommitted row lock, then race a claim.-            threadDelay 500000-            now <- getCurrentTime-            Right claimed <- Store.runStoreIO storeHandle (claimOutboxBatch PerKeyHeadOfLine 10 now)-            fmap (^. #outboxId) claimed `shouldBe` []-            Right () <- takeMVar holderDone-            pure ()--        it "StopTheLine publishes singleton batches and skips the unattempted suffix" $ \storeHandle -> do-            let row1Id = outboxIdFromOrdinal 1-                row2Id = outboxIdFromOrdinal 2-                row3Id = outboxIdFromOrdinal 3-                row4Id = outboxIdFromOrdinal 4-                ids = [row1Id, row2Id, row3Id, row4Id]-                rows =-                    [ (oid, sampleIntegrationEnvelope & #messageId .~ ("stop-line-" <> Text.pack (show i)) & #key .~ Just "stop-key")-                    | (i, oid) <- zip [1 .. 4 :: Int] ids-                    ]-                publishRef = fmap (^. #outboxId)-                publish claimed =-                    pure-                        [ ( row ^. #outboxId-                          , if row ^. #outboxId == row2Id-                                then PublishFailed "stop here"-                                else PublishSucceeded-                          )-                        | row <- claimed-                        ]-            Right () <--                Store.runStoreIO storeHandle $-                    Store.runTransaction $-                        traverse_ (uncurry enqueueIntegrationEventTx) rows-            seenRef <- newIORef []-            let trackedPublish claimed = do-                    liftIO (modifyIORef' seenRef (<> publishRef claimed))-                    publish claimed-                opts = defaultPublishOptions & #orderingPolicy .~ StopTheLine & #backoff .~ ConstantBackoff 0-            Right summary <- Store.runStoreIO storeHandle (publishClaimedOutbox trackedPublish opts Nothing)-            summary ^. #published `shouldBe` 1-            summary ^. #retried `shouldBe` 3-            summary ^. #haltedOn `shouldBe` Just row2Id-            seen <- readIORef seenRef-            seen `shouldBe` take 2 ids-            Right (Just row3) <- Store.runStoreIO storeHandle (lookupOutbox row3Id)-            Right (Just row4) <- Store.runStoreIO storeHandle (lookupOutbox row4Id)-            row3 ^. #status `shouldBe` OutboxFailed-            row3 ^. #attemptCount `shouldBe` 0-            row4 ^. #status `shouldBe` OutboxFailed-            row4 ^. #attemptCount `shouldBe` 0--        it "publishClaimedOutbox treats a missing batch outcome as a failed row" $ \storeHandle -> do-            let okId = outboxIdFromOrdinal 1-                missingId = outboxIdFromOrdinal 2-                okEvent = sampleIntegrationEnvelope & #messageId .~ "missing-outcome-ok" & #key .~ Just "ok-key"-                missingEvent = sampleIntegrationEnvelope & #messageId .~ "missing-outcome-fail" & #key .~ Just "missing-key"-                publish claimed =-                    pure-                        [ (row ^. #outboxId, PublishSucceeded)-                        | row <- claimed-                        , row ^. #outboxId == okId-                        ]-            Right () <--                Store.runStoreIO storeHandle $-                    Store.runTransaction $ do-                        enqueueIntegrationEventTx okId okEvent-                        enqueueIntegrationEventTx missingId missingEvent-            Right summary <- Store.runStoreIO storeHandle (publishClaimedOutbox publish defaultPublishOptions Nothing)-            summary ^. #published `shouldBe` 1-            summary ^. #retried `shouldBe` 1-            Right (Just missingRow) <- Store.runStoreIO storeHandle (lookupOutbox missingId)-            missingRow ^. #status `shouldBe` OutboxFailed-            missingRow ^. #lastError `shouldBe` Just "publisher returned no outcome"--        it "auto-dead-letters a row after maxAttempts consecutive failures" $ \storeHandle -> do-            let oid = OutboxId outboxUuid1-                event = sampleIntegrationEnvelope & #key .~ Nothing-                opts =-                    defaultPublishOptions-                        & #batchSize-                        .~ 10-                        & #maxAttempts-                        .~ 3-                        & #backoff-                        .~ ConstantBackoff 0-                        & #orderingPolicy-                        .~ BestEffort-            Right () <--                Store.runStoreIO storeHandle $-                    Store.runTransaction (enqueueIntegrationEventTx oid event)-            let publish _ = pure (PublishFailed "broker exploded")-            -- First two failures retain Failed status.-            Right s1 <- Store.runStoreIO storeHandle (publishClaimedOutbox (perRow publish) opts Nothing)-            s1 ^. #retried `shouldBe` 1-            s1 ^. #dead `shouldBe` 0-            Right s2 <- Store.runStoreIO storeHandle (publishClaimedOutbox (perRow publish) opts Nothing)-            s2 ^. #retried `shouldBe` 1-            s2 ^. #dead `shouldBe` 0-            -- Third failure crosses the threshold.-            Right s3 <- Store.runStoreIO storeHandle (publishClaimedOutbox (perRow publish) opts Nothing)-            s3 ^. #dead `shouldBe` 1-            Right (Just row) <- Store.runStoreIO storeHandle (lookupOutbox oid)-            row ^. #status `shouldBe` OutboxDead-            -- A dead row is not claimable.-            now <- getCurrentTime-            Right reclaimed <- Store.runStoreIO storeHandle (claimOutboxBatch BestEffort 10 now)-            reclaimed `shouldBe` []--        it "garbageCollectSent deletes only old sent rows" $ \storeHandle -> do-            let oldSentId = OutboxId outboxUuid1-                recentSentId = OutboxId outboxUuid2-                failedId = OutboxId outboxUuid3-                deadId = OutboxId outboxUuid4-                base = sampleIntegrationEnvelope & #key .~ Nothing-            Right () <--                Store.runStoreIO storeHandle $-                    Store.runTransaction (enqueueIntegrationEventTx oldSentId (base & #messageId .~ "gc-old-sent"))-            Right () <--                Store.runStoreIO storeHandle $-                    Store.runTransaction (enqueueIntegrationEventTx recentSentId (base & #messageId .~ "gc-recent-sent"))-            Right () <--                Store.runStoreIO storeHandle $-                    Store.runTransaction (enqueueIntegrationEventTx failedId (base & #messageId .~ "gc-failed"))-            let firstPass row-                    | row ^. #outboxId == failedId = pure (PublishFailed "keep failed")-                    | otherwise = pure PublishSucceeded-                firstPassOpts =-                    defaultPublishOptions-                        & #batchSize-                        .~ 10-                        & #orderingPolicy-                        .~ BestEffort-                        & #backoff-                        .~ ConstantBackoff 3600-            Right _ <- Store.runStoreIO storeHandle (publishClaimedOutbox (perRow firstPass) firstPassOpts Nothing)-            Right () <--                Store.runStoreIO storeHandle $-                    Store.runTransaction (enqueueIntegrationEventTx deadId (base & #messageId .~ "gc-dead"))-            let deadPass row-                    | row ^. #outboxId == deadId = pure (PublishFailed "keep dead")-                    | otherwise = pure PublishSucceeded-                deadPassOpts =-                    defaultPublishOptions-                        & #batchSize-                        .~ 10-                        & #maxAttempts-                        .~ 1-                        & #orderingPolicy-                        .~ BestEffort-            Right _ <- Store.runStoreIO storeHandle (publishClaimedOutbox (perRow deadPass) deadPassOpts Nothing)-            now <- getCurrentTime-            Right () <- Store.runStoreIO storeHandle (backdateOutboxPublishedAt oldSentId (addUTCTime (-3600) now))-            Right deleted <- Store.runStoreIO storeHandle (garbageCollectSent 300 now)-            deleted `shouldBe` 1-            Right oldRow <- Store.runStoreIO storeHandle (lookupOutbox oldSentId)-            oldRow `shouldBe` Nothing-            Right (Just recentRow) <- Store.runStoreIO storeHandle (lookupOutbox recentSentId)-            recentRow ^. #status `shouldBe` OutboxSent-            Right (Just failedRow) <- Store.runStoreIO storeHandle (lookupOutbox failedId)-            failedRow ^. #status `shouldBe` OutboxFailed-            Right (Just deadRow) <- Store.runStoreIO storeHandle (lookupOutbox deadId)-            deadRow ^. #status `shouldBe` OutboxDead--        it "enforces per-key head-of-line blocking and unblocks once the predecessor reaches a terminal state" $ \storeHandle -> do-            let a1Id = OutboxId outboxUuid1-                a2Id = OutboxId outboxUuid2-                b1Id = OutboxId outboxUuid3-                a1 = sampleIntegrationEnvelope & #messageId .~ "a1" & #key .~ Just "k1"-                a2 = sampleIntegrationEnvelope & #messageId .~ "a2" & #key .~ Just "k1"-                b1 = sampleIntegrationEnvelope & #messageId .~ "b1" & #key .~ Just "k2"-            -- Insert in created_at order (a1 first, then a2, then b1).-            Right () <--                Store.runStoreIO storeHandle $-                    Store.runTransaction (enqueueIntegrationEventTx a1Id a1)-            Right () <--                Store.runStoreIO storeHandle $-                    Store.runTransaction (enqueueIntegrationEventTx a2Id a2)-            Right () <--                Store.runStoreIO storeHandle $-                    Store.runTransaction (enqueueIntegrationEventTx b1Id b1)-            claimed <- newIORef []-            let publish row = do-                    liftIO (atomicModifyIORef' claimed (\xs -> ((row ^. #outboxId) : xs, ())))-                    if row ^. #outboxId == a1Id-                        then pure (PublishFailed "broker hiccup")-                        else pure PublishSucceeded-            -- First pass: with a one-row batch, a1 fails and both later rows remain pending.-            let firstPassOpts =-                    defaultPublishOptions-                        & #batchSize-                        .~ 1-                        & #backoff-                        .~ ConstantBackoff 0-            Right summary1 <--                Store.runStoreIO storeHandle (publishClaimedOutbox (perRow publish) firstPassOpts Nothing)-            summary1 ^. #claimed `shouldBe` 1-            claimedIds <- readIORef claimed-            claimedIds `shouldSatisfy` (a2Id `notElem`)-            claimedIds `shouldSatisfy` (a1Id `elem`)-            claimedIds `shouldSatisfy` (b1Id `notElem`)-            Right (Just a1Row) <- Store.runStoreIO storeHandle (lookupOutbox a1Id)-            a1Row ^. #status `shouldBe` OutboxFailed-            Right (Just b1Row) <- Store.runStoreIO storeHandle (lookupOutbox b1Id)-            b1Row ^. #status `shouldBe` OutboxPending-            Right (Just a2Row) <- Store.runStoreIO storeHandle (lookupOutbox a2Id)-            a2Row ^. #status `shouldBe` OutboxPending-            -- Drive a1 to terminal sent state so a2 can move. One pass claims a1-            -- (now that next_attempt_at has passed). A second pass claims a2,-            -- which becomes head-of-line once a1 reaches `sent`.-            writeIORef claimed []-            let publishOk row = do-                    liftIO (atomicModifyIORef' claimed (\xs -> ((row ^. #outboxId) : xs, ())))-                    pure PublishSucceeded-                retryOpts =-                    defaultPublishOptions-                        & #batchSize-                        .~ 1-                        & #backoff-                        .~ ConstantBackoff 0-            Right _ <- Store.runStoreIO storeHandle (publishClaimedOutbox (perRow publishOk) retryOpts Nothing)-            Right _ <- Store.runStoreIO storeHandle (publishClaimedOutbox (perRow publishOk) retryOpts Nothing)-            Right _ <- Store.runStoreIO storeHandle (publishClaimedOutbox (perRow publishOk) retryOpts Nothing)-            claimedIds2 <- readIORef claimed-            claimedIds2 `shouldSatisfy` (a1Id `elem`)-            claimedIds2 `shouldSatisfy` (a2Id `elem`)-            claimedIds2 `shouldSatisfy` (b1Id `elem`)-            Right (Just a2Row') <- Store.runStoreIO storeHandle (lookupOutbox a2Id)-            a2Row' ^. #status `shouldBe` OutboxSent--        it "allows null-keyed rows to publish independently" $ \storeHandle -> do-            let n1 = OutboxId outboxUuid1-                n2 = OutboxId outboxUuid2-                e = sampleIntegrationEnvelope & #key .~ Nothing-            Right () <--                Store.runStoreIO storeHandle $-                    Store.runTransaction (enqueueIntegrationEventTx n1 (e & #messageId .~ "n1"))-            Right () <--                Store.runStoreIO storeHandle $-                    Store.runTransaction (enqueueIntegrationEventTx n2 (e & #messageId .~ "n2"))-            let publish row-                    | row ^. #outboxId == n1 = pure (PublishFailed "transient")-                    | otherwise = pure PublishSucceeded-            Right summary <--                Store.runStoreIO storeHandle $-                    publishClaimedOutbox (perRow publish) (defaultPublishOptions & #backoff .~ ConstantBackoff 0) Nothing-            summary ^. #claimed `shouldBe` 2-            summary ^. #published `shouldBe` 1-            summary ^. #retried `shouldBe` 1--        it "mints message ids with the configured TypeID prefix" $ \storeHandle -> do-            Right minted <--                Store.runStoreIO storeHandle (mintIntegrationEvent sampleProducer sampleDraft)-            minted ^. #source `shouldBe` "ordering"-            minted ^. #destination `shouldBe` "billing.orders.v1"-            Text.isPrefixOf "msg_" (minted ^. #messageId) `shouldBe` True--        it "validates integration producer message id prefixes before startup" $ \_storeHandle -> do-            shouldBeRight_ (mkIntegrationProducer sampleProducer)-            case mkIntegrationProducer (sampleProducer & #messageIdPrefix .~ "Bad-Prefix") of-                Left (InvalidMessageIdPrefix prefix reason) -> do-                    prefix `shouldBe` "Bad-Prefix"-                    reason `shouldSatisfy` (not . Text.null)-                other -> expectationFailure ("expected invalid prefix, got " <> show (void other))--        it "draftToEvent stamps source and messageId without minting" $ \_storeHandle -> do-            let event = draftToEvent "ordering" "msg-fixed-1" sampleDraft-            event ^. #messageId `shouldBe` "msg-fixed-1"-            event ^. #source `shouldBe` "ordering"-            event ^. #destination `shouldBe` "billing.orders.v1"--        it "freshOutboxId returns distinct UUIDv7 ids" $ \storeHandle -> do-            Right ids <--                Store.runStoreIO storeHandle (traverse (\_ -> freshOutboxId) [1 .. 4 :: Int])-            length ids `shouldBe` 4-            length (uniqueIds ids) `shouldBe` 4--        it "publishClaimedOutbox emits a Producer span with messaging semconv attributes" $ \storeHandle -> do-            (processor, spansRef) <- inMemoryListExporter-            provider <- createTracerProvider [processor] emptyTracerProviderOptions-            let tracer = makeTracer provider "keiro-test" tracerOptions-                okId = OutboxId outboxUuid1-                failId = OutboxId outboxUuid2-                okEvent = sampleIntegrationEnvelope-                failEvent =-                    sampleIntegrationEnvelope-                        & #messageId-                        .~ "msg-fail-otel-1"-                        & #key-                        .~ Just "order-otel-fail"-            Right () <--                Store.runStoreIO storeHandle $-                    Store.runTransaction (enqueueIntegrationEventTx okId okEvent)-            Right () <--                Store.runStoreIO storeHandle $-                    Store.runTransaction (enqueueIntegrationEventTx failId failEvent)-            let publish row-                    | row ^. #outboxId == okId = pure PublishSucceeded-                    | otherwise = pure (PublishFailed "broker unreachable")-                opts = defaultPublishOptions & #tracer ?~ tracer-            Right _ <- Store.runStoreIO storeHandle (publishClaimedOutbox (perRow publish) opts Nothing)-            _ <- shutdownTracerProvider provider Nothing-            spans <- traverse captureSpan =<< readIORef spansRef-            length spans `shouldBe` 1-            case spans of-                [batchSpan] -> do-                    csName batchSpan `shouldBe` ("send " <> (okEvent ^. #destination))-                    show (csKind batchSpan) `shouldBe` "Producer"-                    textAttr (csAttributes batchSpan) "messaging.system" `shouldBe` Just "kafka"-                    textAttr (csAttributes batchSpan) "messaging.operation.type" `shouldBe` Just "publish"-                    textAttr (csAttributes batchSpan) "messaging.operation.name" `shouldBe` Just "send"-                    textAttr (csAttributes batchSpan) "messaging.destination.name"-                        `shouldBe` Just (okEvent ^. #destination)-                    textAttr (csAttributes batchSpan) "messaging.kafka.message.key"-                        `shouldBe` (okEvent ^. #key)-                    intAttr (csAttributes batchSpan) "keiro.outbox.batch.size" `shouldBe` Just 2-                    textAttr (csAttributes batchSpan) "error.type" `shouldBe` Just "publish_failed"-                    case csStatus batchSpan of-                        Error msg -> msg `shouldBe` "broker unreachable"-                        other -> expectationFailure ("expected Error \"broker unreachable\", got " <> show other)-                other -> expectationFailure ("expected one batch span, got " <> show (length other))--        it "publishClaimedOutbox records counters and sampleOutboxBacklog records the gauge" $ \storeHandle -> do-            (exporter, metricsRef) <- inMemoryMetricExporter-            (provider, _env) <--                createMeterProvider-                    emptyMaterializedResources-                    defaultSdkMeterProviderOptions{metricExporter = Just exporter}-            meter <- getMeter provider Telemetry.keiroInstrumentationLibrary-            keiroMetrics <- Telemetry.newKeiroMetrics meter-            let okId = OutboxId outboxUuid1-                failId = OutboxId outboxUuid2-                okEvent = sampleIntegrationEnvelope & #messageId .~ "metrics-ok" & #key .~ Nothing-                failEvent = sampleIntegrationEnvelope & #messageId .~ "metrics-fail" & #key .~ Nothing-            Right () <--                Store.runStoreIO storeHandle $-                    Store.runTransaction (enqueueIntegrationEventTx okId okEvent)-            Right () <--                Store.runStoreIO storeHandle $-                    Store.runTransaction (enqueueIntegrationEventTx failId failEvent)-            let publish row-                    | row ^. #outboxId == okId = pure PublishSucceeded-                    | otherwise = pure (PublishFailed "broker down")-                retryPassOpts =-                    defaultPublishOptions-                        & #batchSize-                        .~ 10-                        & #maxAttempts-                        .~ 5-                        & #backoff-                        .~ ConstantBackoff 0-                        & #orderingPolicy-                        .~ BestEffort-                deadPassOpts = retryPassOpts & #maxAttempts .~ 1-            -- Pass 1 (maxAttempts = 5): ok publishes, the fail row retries.-            Right summary1 <--                Store.runStoreIO storeHandle (publishClaimedOutbox (perRow publish) retryPassOpts (Just keiroMetrics))-            summary1 ^. #published `shouldBe` 1-            summary1 ^. #retried `shouldBe` 1-            -- Pass 2 (maxAttempts = 1): the failed row crosses the ceiling and dies.-            Right summary2 <--                Store.runStoreIO storeHandle (publishClaimedOutbox (perRow publish) deadPassOpts (Just keiroMetrics))-            summary2 ^. #dead `shouldBe` 1-            -- Flush so the in-memory exporter receives the aggregates.-            _ <- forceFlushMeterProvider provider Nothing-            exported <- readIORef metricsRef-            let scalars = flattenScalarPoints exported-            -- Counters are cumulative across both passes.-            lookup "keiro.outbox.published" scalars `shouldBe` Just (IntNumber 1)-            lookup "keiro.outbox.retried" scalars `shouldBe` Just (IntNumber 1)-            lookup "keiro.outbox.deadlettered" scalars `shouldBe` Just (IntNumber 1)-            -- Publish passes no longer run the backlog COUNT(*) on the hot path.-            lookup "keiro.outbox.backlog" scalars `shouldBe` Nothing--            Store.runStoreIO storeHandle (sampleOutboxBacklog (Just keiroMetrics)) `shouldReturn` Right ()-            _ <- forceFlushMeterProvider provider Nothing-            sampled <- readIORef metricsRef-            let sampledScalars = flattenScalarPoints sampled-            lookup "keiro.outbox.backlog" sampledScalars `shouldBe` Just (IntNumber 0)--    describe "Keiro.Inbox" $ around (withFreshStore fixture) $ do-        it "runs the handler once and records the row as completed" $ \storeHandle -> do-            Right () <--                Store.runStoreIO storeHandle $-                    Store.runTransaction (Tx.sql "CREATE TABLE IF NOT EXISTS inbox_test_counter (message_id TEXT PRIMARY KEY)")-            let event =-                    sampleIntegrationEnvelope-                        & #messageId-                        .~ "inbox-msg-1"-                        & #source-                        .~ "ordering"-                handler ev =-                    Tx.statement (ev ^. #messageId) inboxTestCounterInsertStmt-            Right result1 <--                Store.runStoreIO storeHandle $-                    runInboxTransaction Nothing PreferIntegrationMessageId event Nothing handler-            case result1 of-                Right (InboxProcessed ()) -> pure ()-                other -> expectationFailure ("expected InboxProcessed, got " <> show other)-            Right rowCount1 <--                Store.runStoreIO storeHandle $-                    Store.runTransaction (Tx.statement () inboxTestCounterCountStmt)-            rowCount1 `shouldBe` 1-            Right (Just inboxRow) <- Store.runStoreIO storeHandle (lookupInbox "ordering" "inbox-msg-1")-            inboxRow ^. #status `shouldBe` InboxCompleted-            inboxRow ^. #completedAt `shouldSatisfy` isJust--        it "treats a redelivery with the same messageId as a duplicate" $ \storeHandle -> do-            Right () <--                Store.runStoreIO storeHandle $-                    Store.runTransaction (Tx.sql "CREATE TABLE IF NOT EXISTS inbox_test_counter (message_id TEXT PRIMARY KEY)")-            let event =-                    sampleIntegrationEnvelope-                        & #messageId-                        .~ "inbox-msg-dup"-                        & #source-                        .~ "ordering"-                handler ev = Tx.statement (ev ^. #messageId) inboxTestCounterInsertStmt-            Right (Right (InboxProcessed ())) <--                Store.runStoreIO storeHandle $-                    runInboxTransaction Nothing PreferIntegrationMessageId event Nothing handler-            Right result2 <--                Store.runStoreIO storeHandle $-                    runInboxTransaction Nothing PreferIntegrationMessageId event Nothing handler-            result2 `shouldBe` Right InboxDuplicate-            Right rowCount <--                Store.runStoreIO storeHandle $-                    Store.runTransaction (Tx.statement () inboxTestCounterCountStmt)-            rowCount `shouldBe` 1--        it "records inbox counters and samples backlog separately under the in-memory exporter" $ \storeHandle -> do-            (exporter, metricsRef) <- inMemoryMetricExporter-            (provider, _env) <--                createMeterProvider-                    emptyMaterializedResources-                    defaultSdkMeterProviderOptions{metricExporter = Just exporter}-            meter <- getMeter provider Telemetry.keiroInstrumentationLibrary-            keiroMetrics <- Telemetry.newKeiroMetrics meter-            Right () <--                Store.runStoreIO storeHandle $-                    Store.runTransaction (Tx.sql "CREATE TABLE IF NOT EXISTS inbox_test_counter (message_id TEXT PRIMARY KEY)")-            let event = sampleIntegrationEnvelope & #messageId .~ "inbox-metrics-dup" & #source .~ "ordering"-                handler ev = Tx.statement (ev ^. #messageId) inboxTestCounterInsertStmt-            -- First delivery runs the handler: processed.-            Right (Right (InboxProcessed ())) <--                Store.runStoreIO storeHandle $-                    runInboxTransaction (Just keiroMetrics) PreferIntegrationMessageId event Nothing handler-            -- Second delivery of the same (source, message_id): duplicate.-            Right result2 <--                Store.runStoreIO storeHandle $-                    runInboxTransaction (Just keiroMetrics) PreferIntegrationMessageId event Nothing handler-            result2 `shouldBe` Right InboxDuplicate-            _ <- forceFlushMeterProvider provider Nothing-            exported <- readIORef metricsRef-            let scalars = flattenScalarPoints exported-            lookup "keiro.inbox.processed" scalars `shouldBe` Just (IntNumber 1)-            lookup "keiro.inbox.duplicates" scalars `shouldBe` Just (IntNumber 1)-            lookup "keiro.inbox.backlog" scalars `shouldBe` Nothing-            Store.runStoreIO storeHandle (sampleInboxBacklog (Just keiroMetrics)) `shouldReturn` Right ()-            _ <- forceFlushMeterProvider provider Nothing-            sampled <- readIORef metricsRef-            let sampledScalars = flattenScalarPoints sampled-            lookup "keiro.inbox.backlog" sampledScalars `shouldBe` Just (IntNumber 0)-            -- The handler ran exactly once (the duplicate path does not re-run it).-            Right rowCount <--                Store.runStoreIO storeHandle $-                    Store.runTransaction (Tx.statement () inboxTestCounterCountStmt)-            rowCount `shouldBe` 1--        it "deduplicates via PreferSourceEventIdentity even when messageId differs" $ \storeHandle -> do-            Right () <--                Store.runStoreIO storeHandle $-                    Store.runTransaction (Tx.sql "CREATE TABLE IF NOT EXISTS inbox_test_counter (message_id TEXT PRIMARY KEY)")-            let shared = sampleIntegrationEnvelope & #source .~ "ordering"-                first = shared & #messageId .~ "republish-1"-                second = shared & #messageId .~ "republish-2"-                handler ev = Tx.statement (ev ^. #messageId) inboxTestCounterInsertStmt-            Right (Right (InboxProcessed ())) <--                Store.runStoreIO storeHandle $-                    runInboxTransaction Nothing PreferSourceEventIdentity first Nothing handler-            Right result2 <--                Store.runStoreIO storeHandle $-                    runInboxTransaction Nothing PreferSourceEventIdentity second Nothing handler-            result2 `shouldBe` Right InboxDuplicate--        it "uses KafkaDeliveryIdentity when supplied" $ \storeHandle -> do-            Right () <--                Store.runStoreIO storeHandle $-                    Store.runTransaction (Tx.sql "CREATE TABLE IF NOT EXISTS inbox_test_counter (message_id TEXT PRIMARY KEY)")-            let event = sampleIntegrationEnvelope & #source .~ "ordering"-                kafka = KafkaDeliveryRef "billing.orders.v1" 0 17-                handler ev = Tx.statement (ev ^. #messageId) inboxTestCounterInsertStmt-            Right (Right (InboxProcessed ())) <--                Store.runStoreIO storeHandle $-                    runInboxTransaction Nothing KafkaDeliveryIdentity event (Just kafka) handler-            Right (Right InboxDuplicate) <--                Store.runStoreIO storeHandle $-                    runInboxTransaction Nothing KafkaDeliveryIdentity event (Just kafka) handler-            Right (Just row) <--                Store.runStoreIO storeHandle $-                    lookupInbox "ordering" "billing.orders.v1:0:17"-            row ^. #status `shouldBe` InboxCompleted--        it "reports DedupePolicyUnsatisfied when the envelope lacks the required field" $ \storeHandle -> do-            let event =-                    sampleIntegrationEnvelope-                        & #source-                        .~ "ordering"-                        & #sourceEventId-                        .~ Nothing-                        & #sourceGlobalPosition-                        .~ Nothing-            Right result <--                Store.runStoreIO storeHandle $-                    runInboxTransaction Nothing PreferSourceEventIdentity event Nothing (\_ -> pure ())-            result `shouldBe` Left (DedupePolicyUnsatisfied PreferSourceEventIdentity)--        it "leaves no inbox row when the handler condemns the transaction" $ \storeHandle -> do-            let event =-                    sampleIntegrationEnvelope-                        & #messageId-                        .~ "inbox-msg-rollback"-                        & #source-                        .~ "ordering"-                handler _ = do-                    Tx.condemn-                    pure ()-            _ <--                Store.runStoreIO storeHandle $-                    runInboxTransaction Nothing PreferIntegrationMessageId event Nothing handler-            Right row <- Store.runStoreIO storeHandle (lookupInbox "ordering" "inbox-msg-rollback")-            row `shouldBe` Nothing--        it "leaves no inbox row when the plain handler throws" $ \storeHandle -> do-            let event =-                    sampleIntegrationEnvelope-                        & #messageId-                        .~ "inbox-msg-throw-plain"-                        & #source-                        .~ "ordering"-                handler _ = (pure $! error "plain inbox handler failed") :: Tx.Transaction ()-            thrown <--                try $-                    Store.runStoreIO storeHandle $-                        runInboxTransaction Nothing PreferIntegrationMessageId event Nothing handler-            case thrown of-                Left (_ :: SomeException) -> pure ()-                Right other -> expectationFailure ("expected handler exception, got " <> show (void other))-            Right row <- Store.runStoreIO storeHandle (lookupInbox "ordering" "inbox-msg-throw-plain")-            row `shouldBe` Nothing--        it "exports markFailedTx from the public inbox module and preserves explicit failure marks" $ \storeHandle -> do-            let event =-                    sampleIntegrationEnvelope-                        & #messageId-                        .~ "inbox-msg-public-failed"-                        & #source-                        .~ "ordering"-                handler _ = do-                    markFailedTx "ordering" "inbox-msg-public-failed" "operator failed" (event ^. #occurredAt)-                    pure ()-            Right (Right (InboxProcessed ())) <--                Store.runStoreIO storeHandle $-                    runInboxTransaction Nothing PreferIntegrationMessageId event Nothing handler-            Right (Just row) <- Store.runStoreIO storeHandle (lookupInbox "ordering" "inbox-msg-public-failed")-            row ^. #status `shouldBe` InboxFailed-            row ^. #lastError `shouldBe` Just "operator failed"--        it "a throwing handler records a failed attempt instead of looping" $ \storeHandle -> do-            let event =-                    sampleIntegrationEnvelope-                        & #messageId-                        .~ "inbox-msg-poison-1"-                        & #source-                        .~ "ordering"-                handler _ = (pure $! error "inbox exploded") :: Tx.Transaction ()-            Right result <--                Store.runStoreIO storeHandle $-                    runInboxTransactionWithRetries Nothing 3 PreferIntegrationMessageId event Nothing handler-            case result of-                Right (InboxHandlerFailed err attempts) -> do-                    Text.isInfixOf "inbox exploded" err `shouldBe` True-                    attempts `shouldBe` 1-                other -> expectationFailure ("expected InboxHandlerFailed, got " <> show other)-            Right (Just row) <- Store.runStoreIO storeHandle (lookupInbox "ordering" "inbox-msg-poison-1")-            row ^. #status `shouldBe` InboxFailed-            row ^. #attemptCount `shouldBe` 1-            row ^. #lastError `shouldSatisfy` maybe False (Text.isInfixOf "inbox exploded")--        it "a transient poison message succeeds on retry" $ \storeHandle -> do-            Right () <--                Store.runStoreIO storeHandle $-                    Store.runTransaction (Tx.sql "CREATE TABLE IF NOT EXISTS inbox_test_counter (message_id TEXT PRIMARY KEY)")-            let event =-                    sampleIntegrationEnvelope-                        & #messageId-                        .~ "inbox-msg-poison-transient"-                        & #source-                        .~ "ordering"-                failOnce _ = (pure $! error "temporary inbox failure") :: Tx.Transaction ()-                succeeding ev = Tx.statement (ev ^. #messageId) inboxTestCounterInsertStmt-            Right result1 <--                Store.runStoreIO storeHandle $-                    runInboxTransactionWithRetries Nothing 3 PreferIntegrationMessageId event Nothing failOnce-            case result1 of-                Right (InboxHandlerFailed _ 1) -> pure ()-                other -> expectationFailure ("expected first failed attempt, got " <> show other)-            Right result2 <--                Store.runStoreIO storeHandle $-                    runInboxTransactionWithRetries Nothing 3 PreferIntegrationMessageId event Nothing succeeding-            result2 `shouldBe` Right (InboxProcessed ())-            Right (Just row) <- Store.runStoreIO storeHandle (lookupInbox "ordering" "inbox-msg-poison-transient")-            row ^. #status `shouldBe` InboxCompleted-            row ^. #attemptCount `shouldBe` 1-            Right rowCount <--                Store.runStoreIO storeHandle $-                    Store.runTransaction (Tx.statement () inboxTestCounterCountStmt)-            rowCount `shouldBe` 1--        it "an unrecoverable message dead-letters at the ceiling" $ \storeHandle -> do-            let event =-                    sampleIntegrationEnvelope-                        & #messageId-                        .~ "inbox-msg-poison-dead"-                        & #source-                        .~ "ordering"-                handler _ = (pure $! error "always broken") :: Tx.Transaction ()-            Right result1 <--                Store.runStoreIO storeHandle $-                    runInboxTransactionWithRetries Nothing 2 PreferIntegrationMessageId event Nothing handler-            Right result2 <--                Store.runStoreIO storeHandle $-                    runInboxTransactionWithRetries Nothing 2 PreferIntegrationMessageId event Nothing handler-            Right result3 <--                Store.runStoreIO storeHandle $-                    runInboxTransactionWithRetries Nothing 2 PreferIntegrationMessageId event Nothing handler-            case (result1, result2, result3) of-                ( Right (InboxHandlerFailed _ 1)-                    , Right (InboxHandlerFailed _ 2)-                    , Right (InboxPreviouslyFailed _)-                    ) -> pure ()-                other -> expectationFailure ("unexpected poison lifecycle: " <> show other)-            Right (Just row) <- Store.runStoreIO storeHandle (lookupInbox "ordering" "inbox-msg-poison-dead")-            row ^. #status `shouldBe` InboxFailed-            row ^. #attemptCount `shouldBe` 2--        it "processes a batch of distinct messages in one transaction" $ \storeHandle -> do-            Right () <--                Store.runStoreIO storeHandle $-                    Store.runTransaction (Tx.sql "CREATE TABLE IF NOT EXISTS inbox_test_counter (message_id TEXT PRIMARY KEY)")-            let events =-                    [ sampleIntegrationEnvelope-                        & #messageId-                        .~ ("inbox-batch-msg-" <> Text.pack (show n))-                        & #source-                        .~ "batch-ordering"-                    | n <- [1 .. 50 :: Int]-                    ]-                handler ev = Tx.statement (ev ^. #messageId) inboxTestCounterInsertStmt-            Right results <--                Store.runStoreIO storeHandle $-                    runInboxTransactionBatch Nothing 3 PreferIntegrationMessageId PersistFullEnvelope ((,Nothing) <$> events) handler-            results `shouldBe` replicate 50 (Right (InboxProcessed ()))-            Right rowCount <--                Store.runStoreIO storeHandle $-                    Store.runTransaction (Tx.statement () inboxTestCounterCountStmt)-            rowCount `shouldBe` 50-            Right inboxRows <- Store.runStoreIO storeHandle (listInbox "batch-ordering")-            length inboxRows `shouldBe` 50-            all ((== InboxCompleted) . (^. #status)) inboxRows `shouldBe` True--        it "deduplicates repeated messages within one batch" $ \storeHandle -> do-            Right () <--                Store.runStoreIO storeHandle $-                    Store.runTransaction (Tx.sql "CREATE TABLE IF NOT EXISTS inbox_test_counter (message_id TEXT PRIMARY KEY)")-            let event =-                    sampleIntegrationEnvelope-                        & #messageId-                        .~ "inbox-batch-dup"-                        & #source-                        .~ "batch-ordering"-                handler ev = Tx.statement (ev ^. #messageId) inboxTestCounterInsertStmt-            Right results <--                Store.runStoreIO storeHandle $-                    runInboxTransactionBatch Nothing 3 PreferIntegrationMessageId PersistFullEnvelope [(event, Nothing), (event, Nothing)] handler-            results `shouldBe` [Right (InboxProcessed ()), Right InboxDuplicate]-            Right rowCount <--                Store.runStoreIO storeHandle $-                    Store.runTransaction (Tx.statement () inboxTestCounterCountStmt)-            rowCount `shouldBe` 1--        it "falls back per message when one batch handler throws" $ \storeHandle -> do-            Right () <--                Store.runStoreIO storeHandle $-                    Store.runTransaction (Tx.sql "CREATE TABLE IF NOT EXISTS inbox_test_counter (message_id TEXT PRIMARY KEY)")-            let events =-                    [ sampleIntegrationEnvelope-                        & #messageId-                        .~ ("inbox-batch-poison-" <> Text.pack (show n))-                        & #source-                        .~ "batch-ordering"-                    | n <- [1 .. 5 :: Int]-                    ]-                handler ev-                    | ev ^. #messageId == "inbox-batch-poison-3" =-                        (pure $! error "batch poison") :: Tx.Transaction ()-                    | otherwise =-                        Tx.statement (ev ^. #messageId) inboxTestCounterInsertStmt-            Right results <--                Store.runStoreIO storeHandle $-                    runInboxTransactionBatch Nothing 3 PreferIntegrationMessageId PersistFullEnvelope ((,Nothing) <$> events) handler-            case results of-                [ Right (InboxProcessed ())-                    , Right (InboxProcessed ())-                    , Right (InboxHandlerFailed err 1)-                    , Right (InboxProcessed ())-                    , Right (InboxProcessed ())-                    ] ->-                        Text.isInfixOf "batch poison" err `shouldBe` True-                other -> expectationFailure ("unexpected batch fallback results: " <> show other)-            Right rowCount <--                Store.runStoreIO storeHandle $-                    Store.runTransaction (Tx.statement () inboxTestCounterCountStmt)-            rowCount `shouldBe` 4-            Right (Just row) <- Store.runStoreIO storeHandle (lookupInbox "batch-ordering" "inbox-batch-poison-3")-            row ^. #status `shouldBe` InboxFailed-            row ^. #attemptCount `shouldBe` 1-            row ^. #lastError `shouldSatisfy` maybe False (Text.isInfixOf "batch poison")--        it "reports duplicates across batch calls" $ \storeHandle -> do-            Right () <--                Store.runStoreIO storeHandle $-                    Store.runTransaction (Tx.sql "CREATE TABLE IF NOT EXISTS inbox_test_counter (message_id TEXT PRIMARY KEY)")-            let event =-                    sampleIntegrationEnvelope-                        & #messageId-                        .~ "inbox-batch-existing-dup"-                        & #source-                        .~ "batch-ordering"-                handler ev = Tx.statement (ev ^. #messageId) inboxTestCounterInsertStmt-            Right first <--                Store.runStoreIO storeHandle $-                    runInboxTransactionBatch Nothing 3 PreferIntegrationMessageId PersistFullEnvelope [(event, Nothing)] handler-            first `shouldBe` [Right (InboxProcessed ())]-            Right second <--                Store.runStoreIO storeHandle $-                    runInboxTransactionBatch Nothing 3 PreferIntegrationMessageId PersistFullEnvelope [(event, Nothing)] handler-            second `shouldBe` [Right InboxDuplicate]-            Right rowCount <--                Store.runStoreIO storeHandle $-                    Store.runTransaction (Tx.statement () inboxTestCounterCountStmt)-            rowCount `shouldBe` 1--        it "falls back per message when one batch handler condemns the transaction" $ \storeHandle -> do-            Right () <--                Store.runStoreIO storeHandle $-                    Store.runTransaction (Tx.sql "CREATE TABLE IF NOT EXISTS inbox_test_counter (message_id TEXT PRIMARY KEY)")-            let events =-                    [ sampleIntegrationEnvelope-                        & #messageId-                        .~ ("inbox-batch-condemn-" <> Text.pack (show n))-                        & #source-                        .~ "batch-ordering"-                    | n <- [1 .. 3 :: Int]-                    ]-                handler ev-                    | ev ^. #messageId == "inbox-batch-condemn-2" = Tx.condemn-                    | otherwise = Tx.statement (ev ^. #messageId) inboxTestCounterInsertStmt-            Right results <--                Store.runStoreIO storeHandle $-                    runInboxTransactionBatch Nothing 3 PreferIntegrationMessageId PersistFullEnvelope ((,Nothing) <$> events) handler-            -- The condemned single-message retry reports processed by the-            -- documented single-path contract; what matters is that the-            -- innocent batch mates actually committed.-            results `shouldBe` replicate 3 (Right (InboxProcessed ()))-            Right rowCount <--                Store.runStoreIO storeHandle $-                    Store.runTransaction (Tx.statement () inboxTestCounterCountStmt)-            rowCount `shouldBe` 2-            Right (Just mate1) <- Store.runStoreIO storeHandle (lookupInbox "batch-ordering" "inbox-batch-condemn-1")-            Right (Just mate3) <- Store.runStoreIO storeHandle (lookupInbox "batch-ordering" "inbox-batch-condemn-3")-            mate1 ^. #status `shouldBe` InboxCompleted-            mate3 ^. #status `shouldBe` InboxCompleted-            Right condemned <- Store.runStoreIO storeHandle (lookupInbox "batch-ordering" "inbox-batch-condemn-2")-            condemned `shouldBe` Nothing--        it "classifies a legacy processing row as InboxInProgress without running the handler" $ \storeHandle -> do-            Right () <--                Store.runStoreIO storeHandle $-                    Store.runTransaction (Tx.sql "CREATE TABLE IF NOT EXISTS inbox_test_counter (message_id TEXT PRIMARY KEY)")-            let event =-                    sampleIntegrationEnvelope-                        & #messageId-                        .~ "inbox-legacy-processing"-                        & #source-                        .~ "ordering"-                handler ev = Tx.statement (ev ^. #messageId) inboxTestCounterInsertStmt-            Right () <--                Store.runStoreIO storeHandle $-                    Store.runTransaction $-                        Tx.sql "INSERT INTO keiro.keiro_inbox (source, dedupe_key, content_type, payload_bytes, status) VALUES ('ordering', 'inbox-legacy-processing', 'application/json', ''::bytea, 'processing')"-            Right result <--                Store.runStoreIO storeHandle $-                    runInboxTransaction Nothing PreferIntegrationMessageId event Nothing handler-            result `shouldBe` Right InboxInProgress-            Right rowCount <--                Store.runStoreIO storeHandle $-                    Store.runTransaction (Tx.statement () inboxTestCounterCountStmt)-            rowCount `shouldBe` 0-            Right (Just row) <- Store.runStoreIO storeHandle (lookupInbox "ordering" "inbox-legacy-processing")-            row ^. #status `shouldBe` InboxProcessing--        it "runs the handler once when two workers race the same dedupe key" $ \storeHandle -> do-            Right () <--                Store.runStoreIO storeHandle $-                    Store.runTransaction (Tx.sql "CREATE TABLE IF NOT EXISTS inbox_test_counter (message_id TEXT PRIMARY KEY)")-            let event =-                    sampleIntegrationEnvelope-                        & #messageId-                        .~ "inbox-race-dup"-                        & #source-                        .~ "ordering"-                slowHandler ev = do-                    Tx.statement (ev ^. #messageId) inboxTestCounterInsertStmt-                    Tx.sql "SELECT pg_sleep(1.5)"-                fastHandler ev = Tx.statement (ev ^. #messageId) inboxTestCounterInsertStmt-            firstDone <- newEmptyMVar-            _ <- forkIO $ do-                first <--                    Store.runStoreIO storeHandle $-                        runInboxTransaction Nothing PreferIntegrationMessageId event Nothing slowHandler-                putMVar firstDone first-            -- Let the slow worker insert its uncommitted row, then race the-            -- same dedupe key: the second insert must block on the unique-            -- constraint until the first commits, then classify as duplicate.-            threadDelay 400000-            Right second <--                Store.runStoreIO storeHandle $-                    runInboxTransaction Nothing PreferIntegrationMessageId event Nothing fastHandler-            Right first <- takeMVar firstDone-            first `shouldBe` Right (InboxProcessed ())-            second `shouldBe` Right InboxDuplicate-            Right rowCount <--                Store.runStoreIO storeHandle $-                    Store.runTransaction (Tx.statement () inboxTestCounterCountStmt)-            rowCount `shouldBe` 1--        it "can persist only dedupe columns for successful rows" $ \storeHandle -> do-            let kafka = KafkaDeliveryRef "billing.orders.v1" 1 42-                event =-                    sampleIntegrationEnvelope-                        & #messageId-                        .~ "inbox-slim-success"-                        & #source-                        .~ "ordering"-                        & #payloadBytes-                        .~ "full success payload"-                        & #attributes-                        ?~ object ["source" Aeson..= ("slim-test" :: Text)]-                handler _ = pure ()-            Right (Right (InboxProcessed ())) <--                Store.runStoreIO storeHandle $-                    runInboxTransactionWith Nothing PersistDedupeOnly PreferIntegrationMessageId event (Just kafka) handler-            Right (Just row) <- Store.runStoreIO storeHandle (lookupInbox "ordering" "inbox-slim-success")-            row ^. #event . #payloadBytes `shouldBe` ""-            row ^. #event . #attributes `shouldBe` Nothing-            row ^. #event . #traceContext `shouldBe` Nothing-            row ^. #event . #schemaReference `shouldBe` Nothing-            row ^. #event . #messageId `shouldBe` "inbox-slim-success"-            row ^. #event . #sourceEventId `shouldBe` event ^. #sourceEventId-            row ^. #event . #sourceGlobalPosition `shouldBe` event ^. #sourceGlobalPosition-            row ^. #event . #causationId `shouldBe` event ^. #causationId-            row ^. #event . #correlationId `shouldBe` event ^. #correlationId-            row ^. #event . #occurredAt `shouldBe` event ^. #occurredAt-            row ^. #kafka `shouldBe` Just kafka-            Right redelivery <--                Store.runStoreIO storeHandle $-                    runInboxTransactionWith Nothing PersistDedupeOnly PreferIntegrationMessageId event (Just kafka) handler-            redelivery `shouldBe` Right InboxDuplicate--        it "keeps full failed rows even when successful rows are dedupe-only" $ \storeHandle -> do-            let event =-                    sampleIntegrationEnvelope-                        & #messageId-                        .~ "inbox-slim-failed"-                        & #source-                        .~ "ordering"-                        & #payloadBytes-                        .~ "full failed payload"-                        & #attributes-                        ?~ object ["source" Aeson..= ("failed-slim-test" :: Text)]-                handler _ = (pure $! error "slim failure") :: Tx.Transaction ()-            Right result <--                Store.runStoreIO storeHandle $-                    runInboxTransactionWithRetriesWith Nothing 3 PersistDedupeOnly PreferIntegrationMessageId event Nothing handler-            case result of-                Right (InboxHandlerFailed err 1) ->-                    Text.isInfixOf "slim failure" err `shouldBe` True-                other -> expectationFailure ("expected InboxHandlerFailed, got " <> show other)-            Right (Just row) <- Store.runStoreIO storeHandle (lookupInbox "ordering" "inbox-slim-failed")-            row ^. #status `shouldBe` InboxFailed-            row ^. #event . #payloadBytes `shouldBe` event ^. #payloadBytes-            row ^. #event . #attributes `shouldBe` event ^. #attributes-            row ^. #event . #traceContext `shouldBe` event ^. #traceContext-            row ^. #event . #schemaReference `shouldBe` event ^. #schemaReference--        it "garbage-collects completed rows older than the retention window" $ \storeHandle -> do-            let event =-                    sampleIntegrationEnvelope-                        & #messageId-                        .~ "inbox-msg-gc"-                        & #source-                        .~ "ordering"-                handler _ = pure ()-            Right (Right (InboxProcessed ())) <--                Store.runStoreIO storeHandle $-                    runInboxTransaction Nothing PreferIntegrationMessageId event Nothing handler-            -- Backdate the row so it falls outside the retention window.-            Right () <--                Store.runStoreIO storeHandle $-                    Store.runTransaction $-                        Tx.sql-                            "UPDATE keiro.keiro_inbox SET completed_at = now() - interval '40 days' WHERE message_id = 'inbox-msg-gc'"-            now <- getCurrentTime-            Right deleted <- Store.runStoreIO storeHandle (garbageCollectCompleted (nominalDays 30) now)-            deleted `shouldBe` 1-            Right rows <- Store.runStoreIO storeHandle (listInbox "ordering")-            rows `shouldBe` []--    describe "Keiro.Inbox.Kafka" $ do-        it "reconstructs an integration event from headers and payload" $ do-            let envelope = sampleIntegrationEnvelope-                headers = integrationHeaders envelope-                receivedAt = addUTCTime 60 (envelope ^. #occurredAt)-                record =-                    InboxKafka.KafkaInboundRecord-                        { topic = "billing.orders.v1"-                        , partition = 2-                        , offset = 113-                        , key = Just "order-123"-                        , payload = envelope ^. #payloadBytes-                        , headers-                        , receivedAt-                        }-            case InboxKafka.integrationEventFromKafka record of-                Right (rebuilt, kafkaRef) -> do-                    rebuilt ^. #messageId `shouldBe` envelope ^. #messageId-                    rebuilt ^. #source `shouldBe` envelope ^. #source-                    rebuilt ^. #destination `shouldBe` envelope ^. #destination-                    rebuilt ^. #eventType `shouldBe` envelope ^. #eventType-                    rebuilt ^. #schemaVersion `shouldBe` envelope ^. #schemaVersion-                    rebuilt ^. #sourceEventId `shouldBe` envelope ^. #sourceEventId-                    rebuilt ^. #sourceGlobalPosition `shouldBe` envelope ^. #sourceGlobalPosition-                    rebuilt ^. #payloadBytes `shouldBe` envelope ^. #payloadBytes-                    rebuilt ^. #occurredAt `shouldBe` envelope ^. #occurredAt-                    rebuilt ^. #attributes `shouldBe` envelope ^. #attributes-                    kafkaRef ^. #topic `shouldBe` "billing.orders.v1"-                    kafkaRef ^. #partition `shouldBe` 2-                    kafkaRef ^. #offset `shouldBe` 113-                Left err -> expectationFailure ("expected Right, got Left " <> show err)--        it "falls back to receivedAt when the occurredAt header is absent" $ do-            let envelope = sampleIntegrationEnvelope-                receivedAt = addUTCTime 60 (envelope ^. #occurredAt)-                headers = filter ((/= "keiro-occurred-at") . Prelude.fst) (integrationHeaders envelope)-                record =-                    InboxKafka.KafkaInboundRecord-                        { topic = "billing.orders.v1"-                        , partition = 2-                        , offset = 113-                        , key = Just "order-123"-                        , payload = envelope ^. #payloadBytes-                        , headers-                        , receivedAt-                        }-            case InboxKafka.integrationEventFromKafka record of-                Right (rebuilt, _) -> rebuilt ^. #occurredAt `shouldBe` receivedAt-                Left err -> expectationFailure ("expected Right, got Left " <> show err)--        it "rejects malformed occurredAt headers" $ do-            let envelope = sampleIntegrationEnvelope-                headers = ("keiro-occurred-at", "not-a-time") : filter ((/= "keiro-occurred-at") . Prelude.fst) (integrationHeaders envelope)-                record =-                    InboxKafka.KafkaInboundRecord-                        { topic = "billing.orders.v1"-                        , partition = 2-                        , offset = 113-                        , key = Just "order-123"-                        , payload = envelope ^. #payloadBytes-                        , headers-                        , receivedAt = envelope ^. #occurredAt-                        }-            InboxKafka.integrationEventFromKafka record-                `shouldBe` Left (InboxKafka.InvalidTimeHeader "keiro-occurred-at" "not-a-time")--        it "reports MissingHeader for an essential header" $ do-            let envelope = sampleIntegrationEnvelope-                headers = filter ((/= "keiro-message-id") . Prelude.fst) (integrationHeaders envelope)-                record =-                    InboxKafka.KafkaInboundRecord-                        { topic = "billing.orders.v1"-                        , partition = 0-                        , offset = 0-                        , key = Nothing-                        , payload = envelope ^. #payloadBytes-                        , headers-                        , receivedAt = envelope ^. #occurredAt-                        }-            InboxKafka.integrationEventFromKafka record-                `shouldBe` Left (InboxKafka.MissingHeader "keiro-message-id")--        it "withConsumerSpan parents the consumer span under an upstream producer span via W3C headers" $ do-            (processor, spansRef) <- inMemoryListExporter-            provider <- createTracerProvider [processor] emptyTracerProviderOptions-            let tracer = makeTracer provider "keiro-test" tracerOptions-                -- Clear the baked-in TraceContext on the sample so the only-                -- `traceparent` on the wire comes from the active producer-                -- span (via `injectTraceContext`).-                envelope = sampleIntegrationEnvelope & #traceContext .~ Nothing-                producerRecord = OutboxKafka.integrationEventToKafkaRecord envelope-            producerHeadersText <--                Telemetry.withProducerSpan (Just tracer) envelope producerRecord $ \_ -> do-                    let baseHeaders =-                            [(TE.decodeUtf8 n, TE.decodeUtf8 v) | (n, v) <- producerRecord ^. #headers]-                    Telemetry.injectTraceContext baseHeaders-            -- Build the inbound record the consumer would receive and open the-            -- consumer span around a no-op body.-            now <- getCurrentTime-            let inbound =-                    InboxKafka.KafkaInboundRecord-                        { topic = envelope ^. #destination-                        , partition = 7-                        , offset = 42-                        , key = envelope ^. #key-                        , payload = envelope ^. #payloadBytes-                        , headers = producerHeadersText-                        , receivedAt = now-                        }-            Telemetry.withConsumerSpan (Just tracer) (Just "billing-cg") inbound (Just envelope) $ \_ ->-                pure ()-            _ <- shutdownTracerProvider provider Nothing-            spans <- traverse captureSpan =<< readIORef spansRef-            length spans `shouldBe` 2-            let findByName needle = case [s | s <- spans, csName s == needle] of-                    (s : _) -> s-                    [] -> error ("no span captured with name=" <> Text.unpack needle)-                producerSp = findByName ("send " <> envelope ^. #destination)-                consumerSp = findByName ("process " <> envelope ^. #destination)-            -- Same trace id end-to-end (cross-process parenting).-            traceId (csContext producerSp) `shouldBe` traceId (csContext consumerSp)-            -- Consumer's parent is the producer span.-            case csParent consumerSp of-                Nothing -> expectationFailure "consumer span has no parent"-                Just parent -> do-                    parentCtx <- getSpanContext parent-                    spanId parentCtx `shouldBe` spanId (csContext producerSp)-            -- Consumer span carries the expected attributes.-            show (csKind consumerSp) `shouldBe` "Consumer"-            textAttr (csAttributes consumerSp) "messaging.system" `shouldBe` Just "kafka"-            textAttr (csAttributes consumerSp) "messaging.operation.type" `shouldBe` Just "process"-            textAttr (csAttributes consumerSp) "messaging.destination.name"-                `shouldBe` Just (envelope ^. #destination)-            textAttr (csAttributes consumerSp) "messaging.destination.partition.id"-                `shouldBe` Just "7"-            textAttr (csAttributes consumerSp) "messaging.consumer.group.name"-                `shouldBe` Just "billing-cg"-            textAttr (csAttributes consumerSp) "messaging.message.id"-                `shouldBe` Just (envelope ^. #messageId)--    describe "Keiro cross-context Kafka integration" $ around (withFreshStores2 fixture) $ do-        it "publishes an Ordering integration event and runs the Billing handler exactly once across duplicate deliveries" $ \(ordering, billing) -> do-            Right () <--                Store.runStoreIO billing $-                    Store.runTransaction (Tx.sql "CREATE TABLE IF NOT EXISTS billing_received_orders (order_id TEXT PRIMARY KEY, quantity BIGINT NOT NULL)")-            topic <- newKafkaTopic-            -- Ordering side: enqueue an outbox row representing a published event.-            let orderingEvent = orderSubmittedEnvelope "order-aaa" 7 "msg-aaa"-                oid = OutboxId outboxUuid1-            Right () <--                Store.runStoreIO ordering $-                    Store.runTransaction (enqueueIntegrationEventTx oid orderingEvent)-            -- Run the publisher worker: push records to the in-process topic.-            Right pubSummary1 <--                Store.runStoreIO ordering $-                    publishClaimedOutbox (perRow (kafkaTopicPublish topic)) defaultPublishOptions Nothing-            pubSummary1 ^. #published `shouldBe` 1-            -- Billing side: consume from the topic.-            records1 <- drainKafkaTopic topic-            record1 <- case records1 of-                [r] -> pure r-                other -> expectationFailure ("expected 1 record, got " <> show (length other)) *> error "unreachable"-            Right consumed1 <--                Store.runStoreIO billing $-                    consumeAndApply record1 billingReactionHandler-            consumed1 `shouldBe` ConsumeApplied (InboxProcessed ())-            Right rowCount1 <--                Store.runStoreIO billing $-                    Store.runTransaction (Tx.statement () billingReceivedOrdersCountStmt)-            rowCount1 `shouldBe` 1--            -- Simulate Kafka redelivery: pretend the same Kafka record was-            -- delivered again at a different offset. The producer also retries-            -- (the outbox flips back to pending and the worker republishes).-            let redelivered = redeliverWithDifferentOffset record1-            Right consumed2 <--                Store.runStoreIO billing $-                    consumeAndApply redelivered billingReactionHandler-            consumed2 `shouldBe` ConsumeApplied InboxDuplicate-            Right rowCount2 <--                Store.runStoreIO billing $-                    Store.runTransaction (Tx.statement () billingReceivedOrdersCountStmt)-            rowCount2 `shouldBe` 1--        it "preserves per-partition ordering for two events sharing a Kafka key" $ \(ordering, billing) -> do-            Right () <--                Store.runStoreIO billing $-                    Store.runTransaction (Tx.sql "CREATE TABLE IF NOT EXISTS billing_received_orders (order_id TEXT PRIMARY KEY, quantity BIGINT NOT NULL)")-            Right () <--                Store.runStoreIO billing $-                    Store.runTransaction (Tx.sql "CREATE TABLE IF NOT EXISTS billing_event_log (seq BIGSERIAL PRIMARY KEY, source TEXT NOT NULL, event_type TEXT NOT NULL, order_id TEXT NOT NULL)")-            topic <- newKafkaTopic-            -- Two events for the same order key.-            let submittedEnv = orderSubmittedEnvelope "order-bbb" 4 "msg-bbb-1"-                cancelledEnv = orderCancelledEnvelope "order-bbb" "msg-bbb-2"-                submittedId = OutboxId outboxUuid1-                cancelledId = OutboxId outboxUuid2-            Right () <--                Store.runStoreIO ordering $-                    Store.runTransaction (enqueueIntegrationEventTx submittedId submittedEnv)-            Right () <--                Store.runStoreIO ordering $-                    Store.runTransaction (enqueueIntegrationEventTx cancelledId cancelledEnv)-            -- Run-claiming lets a same-key contiguous run drain in one pass.-            let drainOnce =-                    publishClaimedOutbox-                        (perRow (kafkaTopicPublish topic))-                        (defaultPublishOptions & #backoff .~ ConstantBackoff 0)-                        Nothing-            Right s1 <- Store.runStoreIO ordering drainOnce-            Right s2 <- Store.runStoreIO ordering drainOnce-            (s1 ^. #published) + (s2 ^. #published) `shouldBe` 2-            records <- drainKafkaTopic topic-            length records `shouldBe` 2-            -- Apply both records to billing in delivery order.-            for_ records $ \record -> do-                Right consumed <--                    Store.runStoreIO billing $-                        consumeAndApply record (loggingReactionHandler "billing")-                case consumed of-                    ConsumeApplied (InboxProcessed ()) -> pure ()-                    other -> expectationFailure ("expected processed, got " <> show other)-            Right events <--                Store.runStoreIO billing $-                    Store.runTransaction (Tx.statement () billingEventLogStmt)-            events `shouldBe` [("OrderSubmitted", "order-bbb"), ("OrderCancelled", "order-bbb")]--        it "head-of-line blocks a same-key successor when the first send fails repeatedly until the first row reaches dead status" $ \(ordering, billing) -> do-            Right () <--                Store.runStoreIO billing $-                    Store.runTransaction (Tx.sql "CREATE TABLE IF NOT EXISTS billing_received_orders (order_id TEXT PRIMARY KEY, quantity BIGINT NOT NULL)")-            topic <- newKafkaTopic-            let submittedEnv = orderSubmittedEnvelope "order-ccc" 1 "msg-ccc-1"-                cancelledEnv = orderCancelledEnvelope "order-ccc" "msg-ccc-2"-                firstId = OutboxId outboxUuid1-                secondId = OutboxId outboxUuid2-            Right () <--                Store.runStoreIO ordering $-                    Store.runTransaction (enqueueIntegrationEventTx firstId submittedEnv)-            Right () <--                Store.runStoreIO ordering $-                    Store.runTransaction (enqueueIntegrationEventTx secondId cancelledEnv)-            -- Failing publish for the first row, success for any other.-            let publish row-                    | row ^. #outboxId == firstId =-                        pure (PublishFailed "simulated broker reject")-                    | otherwise = do-                        kafkaTopicAccept topic row-                        pure PublishSucceeded-                deadOpts =-                    defaultPublishOptions-                        & #batchSize-                        .~ 1-                        & #backoff-                        .~ ConstantBackoff 0-                        & #maxAttempts-                        .~ 2-            -- This test drives the pre-M3 sequential failure/dead-letter path-            -- with one-row batches. M3 adds suffix skipping for larger claimed-            -- same-key runs.-            -- First pass: the first row attempts once and fails; the second is-            -- outside the one-row claim window.-            Right pass1 <- Store.runStoreIO ordering (publishClaimedOutbox (perRow publish) deadOpts Nothing)-            pass1 ^. #retried `shouldBe` 1-            pass1 ^. #published `shouldBe` 0-            -- Second pass crosses maxAttempts and dead-letters the first row.-            Right pass2 <- Store.runStoreIO ordering (publishClaimedOutbox (perRow publish) deadOpts Nothing)-            pass2 ^. #dead `shouldBe` 1-            Right (Just firstRow) <- Store.runStoreIO ordering (lookupOutbox firstId)-            firstRow ^. #status `shouldBe` OutboxDead-            -- With the first row dead, the second becomes claimable and publishes.-            Right pass3 <- Store.runStoreIO ordering (publishClaimedOutbox (perRow publish) deadOpts Nothing)-            pass3 ^. #published `shouldBe` 1-            Right (Just secondRow) <- Store.runStoreIO ordering (lookupOutbox secondId)-            secondRow ^. #status `shouldBe` OutboxSent-            -- Billing only sees the second event.-            records <- drainKafkaTopic topic-            record <- case records of-                [r] -> pure r-                other -> expectationFailure ("expected 1 record, got " <> show (length other)) *> error "unreachable"-            Right consumed <--                Store.runStoreIO billing $-                    consumeAndApply record billingReactionHandler-            consumed `shouldBe` ConsumeApplied (InboxProcessed ())--    describe "Keiro.Integration.Event" $ do-        it "round-trips a JSON envelope through encode and decode" $ do-            let envelope = sampleIntegrationEnvelope-                payload = OrderSubmittedPayload "order-123" 5-                encoded = encodeJsonIntegrationEvent envelope payload-            decodeJsonIntegrationEvent encoded `shouldBe` Right payload--        it "preserves identity and routing through encode" $ do-            let envelope = sampleIntegrationEnvelope-                encoded = encodeJsonIntegrationEvent envelope (OrderSubmittedPayload "order-123" 5)-            encoded ^. #messageId `shouldBe` envelope ^. #messageId-            encoded ^. #source `shouldBe` "ordering"-            encoded ^. #destination `shouldBe` "billing.orders.v1"-            encoded ^. #key `shouldBe` Just "order-123"-            encoded ^. #eventType `shouldBe` "OrderSubmitted"-            encoded ^. #schemaVersion `shouldBe` 1-            encoded ^. #contentType `shouldBe` ApplicationJson--        it "emits the canonical wire headers" $ do-            let envelope = sampleIntegrationEnvelope-                headers = integrationHeaders envelope-            Prelude.lookup headerMessageId headers `shouldBe` Just (envelope ^. #messageId)-            Prelude.lookup headerSchemaVersion headers `shouldBe` Just "1"-            Prelude.lookup headerContentType headers `shouldBe` Just "application/json"-            Prelude.lookup headerSchemaSubject headers `shouldBe` Just "billing.orders.v1.OrderSubmitted"-            Prelude.lookup headerSourceEventId headers `shouldBe` Just "018f0f18-17aa-7000-8000-000000000003"-            Prelude.lookup headerSourceGlobalPosition headers `shouldBe` Just "42"-            Prelude.lookup headerTraceParent headers-                `shouldBe` Just "00-0af7651916cd43dd8448eb211c80319c-b7ad6b7169203331-01"--        it "preserves a different content type without claiming JSON" $ do-            let envelope =-                    sampleIntegrationEnvelope-                        & #contentType-                        .~ OtherContentType "application/vnd.apache.avro.binary"-                        & #payloadBytes-                        .~ "\x00\x01\x02"-                headers = integrationHeaders envelope-            Prelude.lookup headerContentType headers-                `shouldBe` Just "application/vnd.apache.avro.binary"-            decodeJsonIntegrationEvent envelope-                `shouldBe` ( Left (IntegrationEvent.UnsupportedContentType "application/vnd.apache.avro.binary") ::-                                Either IntegrationEvent.IntegrationEventError OrderSubmittedPayload-                           )--        it "reports malformed JSON payloads as decode errors instead of throwing" $ do-            let envelope =-                    sampleIntegrationEnvelope-                        & #payloadBytes-                        .~ "{not-json"-            case decodeJsonIntegrationEvent envelope :: Either IntegrationEvent.IntegrationEventError OrderSubmittedPayload of-                Left (IntegrationEvent.MalformedPayload _) -> pure ()-                other -> expectationFailure ("expected MalformedPayload, got " <> show other)--        it "reports a JSON value that does not satisfy the target type as DecodeFailed" $ do-            let envelope =-                    sampleIntegrationEnvelope-                        & #payloadBytes-                        .~ "{\"orderId\":\"order-123\"}"-            case decodeJsonIntegrationEvent envelope :: Either IntegrationEvent.IntegrationEventError OrderSubmittedPayload of-                Left (IntegrationEvent.DecodeFailed _) -> pure ()-                other -> expectationFailure ("expected DecodeFailed, got " <> show other)--        it "parses content-type headers back to the canonical type" $ do-            parseContentType "application/json" `shouldBe` ApplicationJson-            parseContentType "Application/JSON" `shouldBe` ApplicationJson-            parseContentType "application/json; charset=utf-8" `shouldBe` ApplicationJson-            parseContentType "APPLICATION/JSON ; CHARSET=UTF-8" `shouldBe` ApplicationJson-            parseContentType "application/vnd.apache.avro.binary"-                `shouldBe` OtherContentType "application/vnd.apache.avro.binary"--        it "preserves the payload bytes through integrationPayload" $ do-            let envelope = sampleIntegrationEnvelope-                encoded = encodeJsonIntegrationEvent envelope (OrderSubmittedPayload "order-123" 5)-            integrationPayload encoded `shouldBe` (encoded ^. #payloadBytes)--    describe "Keiro.Telemetry" $ do-        it "is a pass-through under a noop (Nothing) tracer" $ do-            counter <- newIORef (0 :: Int)-            let envelope = sampleIntegrationEnvelope-                record = OutboxKafka.integrationEventToKafkaRecord envelope-            result <--                Telemetry.withProducerSpan Nothing envelope record $ \mSpan -> do-                    atomicModifyIORef' counter (\n -> (n + 1, ()))-                    pure (mSpan, "ok" :: Text)-            callsAfter <- readIORef counter-            callsAfter `shouldBe` (1 :: Int)-            snd result `shouldBe` "ok"-            fst result `shouldSatisfy` isNothing--        it "re-exports AttributeKeys whose textual payload matches the spec name" $ do-            attrKeyText Telemetry.messaging_operation_type `shouldBe` "messaging.operation.type"-            attrKeyText Telemetry.messaging_operation_name `shouldBe` "messaging.operation.name"-            attrKeyText Telemetry.messaging_destination_partition_id `shouldBe` "messaging.destination.partition.id"-            attrKeyText Telemetry.messaging_consumer_group_name `shouldBe` "messaging.consumer.group.name"-            attrKeyText Telemetry.messaging_client_id `shouldBe` "messaging.client.id"-            attrKeyTextInt64 Telemetry.messaging_kafka_offset `shouldBe` "messaging.kafka.offset"-            attrKeyText Telemetry.db_system_name `shouldBe` "db.system.name"-            attrKeyText Telemetry.db_namespace `shouldBe` "db.namespace"-            attrKeyText Telemetry.db_collection_name `shouldBe` "db.collection.name"-            attrKeyText Telemetry.db_operation_name `shouldBe` "db.operation.name"-            attrKeyText Telemetry.keiro_stream_name `shouldBe` "keiro.stream.name"-            attrKeyTextInt64 Telemetry.keiro_retry_attempt `shouldBe` "keiro.retry.attempt"-            attrKeyTextInt64 Telemetry.keiro_events_appended `shouldBe` "keiro.events.appended"-            attrKeyText Telemetry.keiro_replay_divergence `shouldBe` "keiro.replay.divergence"--        it "extracts a TraceContext from a W3C traceparent header pair" $ do-            let traceparent = "00-0af7651916cd43dd8448eb211c80319c-b7ad6b7169203331-01"-                tracestate = "vendor1=value1"-                hs = [(headerTraceParent, traceparent), ("tracestate", tracestate)]-            Telemetry.traceContextFromHeaders hs-                `shouldBe` Just (TraceContext traceparent (Just tracestate))--        it "returns Nothing when the traceparent header is missing" $ do-            Telemetry.traceContextFromHeaders [("content-type", "application/json")]-                `shouldBe` Nothing--        it "injectTraceContext is a no-op when no span is active on the thread" $ do-            let baseline = [("content-type", "application/json")]-            injected <- Telemetry.injectTraceContext baseline-            injected `shouldBe` baseline--        it "traceContextFromCurrentSpan returns Nothing outside any span" $ do-            tc <- Telemetry.traceContextFromCurrentSpan-            tc `shouldBe` Nothing--    describe "Keiro.Workflow" $ around (withFreshStore fixture) $ do-        it "journals each step once, returns Completed, and runs each side effect once" $ \storeHandle -> do-            counter <- newIORef (0 :: Int)-            let name = WorkflowName "demo"-                wid = WorkflowId "demo-1"-            result <- Store.runStoreIO storeHandle $ runWorkflow name wid (demoWorkflow counter)-            result `shouldBe` Right (Completed (1, 2))-            sideEffects <- readIORef counter-            sideEffects `shouldBe` 2-            Right recorded <--                Store.runStoreIO storeHandle $-                    Store.readStreamForward (StreamName "wf:demo-demo-1") (StreamVersion 0) 10-            Vector.length recorded `shouldBe` 3-            traverse (decodeRecorded workflowJournalCodec) (Vector.toList recorded)-                `shouldSatisfy` \case-                    Right [StepRecorded "first" _ _, StepRecorded "second" _ _, WorkflowCompleted _] -> True-                    _ -> False--        it "replays recorded steps without re-running their side effects" $ \storeHandle -> do-            counter <- newIORef (0 :: Int)-            let name = WorkflowName "replay"-                wid = WorkflowId "r-1"-            first <- Store.runStoreIO storeHandle $ runWorkflow name wid (demoWorkflow counter)-            first `shouldBe` Right (Completed (1, 2))-            afterFirst <- readIORef counter-            afterFirst `shouldBe` 2-            -- A second run with the same id is exactly the crash-restart scenario.-            second <- Store.runStoreIO storeHandle $ runWorkflow name wid (demoWorkflow counter)-            second `shouldBe` Right (Completed (1, 2))-            afterSecond <- readIORef counter-            afterSecond `shouldBe` 2-            -- The deterministic ids and pre-load gating leave the journal at 3 events.-            Right recorded <--                Store.runStoreIO storeHandle $-                    Store.readStreamForward (StreamName "wf:replay-r-1") (StreamVersion 0) 10-            Vector.length recorded `shouldBe` 3--        it "reuses the recorded result for a repeated step name in one run" $ \storeHandle -> do-            counter <- newIORef (0 :: Int)-            let name = WorkflowName "samename"-                wid = WorkflowId "s-1"-                duplicateStepWorkflow = do-                    a <- step (StepName "dup") (liftIO (incrementAndRead counter))-                    b <- step (StepName "dup") (liftIO (incrementAndRead counter))-                    pure (a, b)-            result <- Store.runStoreIO storeHandle $ runWorkflow name wid duplicateStepWorkflow-            result `shouldBe` Right (Completed (1, 1))-            sideEffects <- readIORef counter-            sideEffects `shouldBe` 1--        it "suspends on an unresolved awaitStep, journaling no completion" $ \storeHandle -> do-            let name = WorkflowName "awaiter"-                wid = WorkflowId "a-1"-            result <- Store.runStoreIO storeHandle $ runWorkflow name wid neverArmingWorkflow-            result `shouldBe` Right Suspended-            Right recorded <--                Store.runStoreIO storeHandle $-                    Store.readStreamForward (StreamName "wf:awaiter-a-1") (StreamVersion 0) 10-            Vector.length recorded `shouldBe` 0--        it "resumes and completes once an awaited step is externally completed" $ \storeHandle -> do-            let name = WorkflowName "awaiter2"-                wid = WorkflowId "a-2"-            suspended <- Store.runStoreIO storeHandle $ runWorkflow name wid neverArmingWorkflow-            suspended `shouldBe` Right Suspended-            -- Simulate a wake source recording the awaited step's resolution.-            Right () <- Store.runStoreIO storeHandle $ do-                now <- liftIO getCurrentTime-                appendJournalEntry name wid (StepRecorded "awk:test" (toJSON (42 :: Int)) now)-            resumed <- Store.runStoreIO storeHandle $ runWorkflow name wid neverArmingWorkflow-            resumed `shouldBe` Right (Completed 42)-            Right recorded <--                Store.runStoreIO storeHandle $-                    Store.readStreamForward (StreamName "wf:awaiter2-a-2") (StreamVersion 0) 10-            traverse (decodeRecorded workflowJournalCodec) (Vector.toList recorded)-                `shouldSatisfy` \case-                    Right [StepRecorded "awk:test" _ _, WorkflowCompleted _] -> True-                    _ -> False--        it "treats a duplicate external journal append as idempotent" $ \storeHandle -> do-            let name = WorkflowName "duplicate-append"-                wid = WorkflowId "da-1"-                stepKey = "awk:test"-                eventAt t = StepRecorded stepKey (toJSON (42 :: Int)) t-            now <- getCurrentTime-            Right firstId <--                Store.runStoreIO storeHandle $-                    appendJournalEntryReturningId name wid (eventAt now)-            secondResult <--                Store.runStoreIO storeHandle $-                    appendJournalEntryReturningId name wid (eventAt now)-            secondId <- case secondResult of-                Right value -> pure value-                Left err -> expectationFailure ("expected idempotent duplicate append, got " <> show err) *> error "unreachable"-            secondId `shouldBe` firstId-            Right indexed <- Store.runStoreIO storeHandle $ loadStepIndex name wid 0-            Map.lookup stepKey indexed `shouldBe` Just (toJSON (42 :: Int))-            Right recorded <--                Store.runStoreIO storeHandle $-                    Store.readStreamForward (StreamName "wf:duplicate-append-da-1") (StreamVersion 0) 10-            Vector.length recorded `shouldBe` 1--        it "returns the journaled value when another writer records the same step mid-flight" $ \storeHandle -> do-            let name = WorkflowName "journal-race"-                wid = WorkflowId "jr-1"-                body =-                    step (StepName "raced") $ do-                        now <- liftIO getCurrentTime-                        appendJournalEntry name wid (StepRecorded "raced" (toJSON ("winner" :: Text)) now)-                        pure ("loser" :: Text)-            outcome <- Store.runStoreIO storeHandle $ runWorkflow name wid body-            outcome `shouldBe` Right (Completed "winner")-            Right recorded <--                Store.runStoreIO storeHandle $-                    Store.readStreamForward (StreamName "wf:journal-race-jr-1") (StreamVersion 0) 10-            traverse (decodeRecorded workflowJournalCodec) (Vector.toList recorded)-                `shouldSatisfy` \case-                    Right [StepRecorded "raced" value _, WorkflowCompleted _] -> value == toJSON ("winner" :: Text)-                    _ -> False--        it "returns the JSON round-trip of a fresh step result" $ \storeHandle -> do-            let name = WorkflowName "roundtrip-step"-                wid = WorkflowId "rs-1"-                body = step (StepName "approx") (pure (Approx 1.7))-            first <- Store.runStoreIO storeHandle $ runWorkflow name wid body-            first `shouldBe` Right (Completed (Approx 2.0))-            replay <- Store.runStoreIO storeHandle $ runWorkflow name wid body-            replay `shouldBe` Right (Completed (Approx 2.0))--        it "throws WorkflowStepDecodeError on the first run when the recorded result cannot decode" $ \storeHandle -> do-            let name = WorkflowName "bad-roundtrip"-                wid = WorkflowId "br-1"-                body = step (StepName "bad") (pure RejectingRoundTrip)-            Store.runStoreIO storeHandle (runWorkflow name wid body)-                `shouldThrow` \case-                    WorkflowStepDecodeError key _ -> key == "bad"-                    _ -> False-            Store.runStoreIO storeHandle (stepExists name wid 0 "bad")-                `shouldReturn` Right True--        it "discovers unfinished workflows via the step index" $ \storeHandle -> do-            counter <- newIORef (0 :: Int)-            Right (Completed _) <--                Store.runStoreIO storeHandle $-                    runWorkflow (WorkflowName "done") (WorkflowId "d-1") (demoWorkflow counter)-            Right Suspended <--                Store.runStoreIO storeHandle $-                    runWorkflow (WorkflowName "pending") (WorkflowId "p-1") (stepThenAwaitWorkflow counter)-            now <- getCurrentTime-            Right unfinished <- Store.runStoreIO storeHandle (findUnfinishedWorkflowIds now)-            unfinished `shouldBe` [("p-1", "pending")]--    describe "Keiro.Workflow instance table" $ around (withFreshStore fixture) $ do-        it "creates and completes a workflow instance row transactionally with the journal" $ \storeHandle -> do-            counter <- newIORef (0 :: Int)-            let name = WorkflowName "inst-complete"-                wid = WorkflowId "ic-1"-            Right (Completed _) <- Store.runStoreIO storeHandle $ runWorkflow name wid (demoWorkflow counter)-            Right (Just row) <- Store.runStoreIO storeHandle $ Instance.lookupInstance name wid-            row ^. #workflowId `shouldBe` "ic-1"-            row ^. #workflowName `shouldBe` "inst-complete"-            row ^. #generation `shouldBe` 0-            row ^. #status `shouldBe` Instance.WfCompleted-            row ^. #completedAt `shouldSatisfy` isJust--        it "records suspended status for workflows that park before journaling" $ \storeHandle -> do-            let name = WorkflowName "inst-suspended"-                wid = WorkflowId "is-1"-            Right Suspended <- Store.runStoreIO storeHandle $ runWorkflow name wid neverArmingWorkflow-            Right (Just row) <- Store.runStoreIO storeHandle $ Instance.lookupInstance name wid-            row ^. #status `shouldBe` Instance.WfSuspended-            row ^. #generation `shouldBe` 0-            row ^. #completedAt `shouldBe` Nothing--        it "creates child instance rows at spawn time and flips them to cancelled" $ \storeHandle -> do-            let childWid = WorkflowId "inst-child"-                childName = WorkflowName "ship"-            Right Suspended <--                Store.runStoreIO storeHandle $-                    runWorkflow (WorkflowName "inst-parent") (WorkflowId "ip-1") (parentWorkflow childWid)-            Right (Just spawned) <- Store.runStoreIO storeHandle $ Instance.lookupInstance childName childWid-            spawned ^. #status `shouldBe` Instance.WfRunning-            Right True <- Store.runStoreIO storeHandle $ cancelChild (ChildHandle childName childWid)-            Right (Just cancelledRow) <- Store.runStoreIO storeHandle $ Instance.lookupInstance childName childWid-            cancelledRow ^. #status `shouldBe` Instance.WfCancelled-            cancelledRow ^. #completedAt `shouldSatisfy` isJust--        it "bumps the instance generation when continueAsNew rotates" $ \storeHandle -> do-            counter <- newIORef (0 :: Int)-            let name = WorkflowName "inst-rotate"-                wid = WorkflowId "ir-1"-            Right ContinuedAsNew <--                Store.runStoreIO storeHandle $-                    runWorkflow name wid (rollingTotal counter 1 2)-            Right (Just row) <- Store.runStoreIO storeHandle $ Instance.lookupInstance name wid-            row ^. #generation `shouldBe` 1-            row ^. #status `shouldBe` Instance.WfRunning--        it "does not let a late append resurrect a terminal instance row" $ \storeHandle -> do-            counter <- newIORef (0 :: Int)-            let name = WorkflowName "inst-terminal"-                wid = WorkflowId "it-1"-            Right (Completed _) <- Store.runStoreIO storeHandle $ runWorkflow name wid (demoWorkflow counter)-            now <- getCurrentTime-            Right () <--                Store.runStoreIO storeHandle $-                    appendJournalEntry name wid (StepRecorded "late" (toJSON True) now)-            Right (Just row) <- Store.runStoreIO storeHandle $ Instance.lookupInstance name wid-            row ^. #status `shouldBe` Instance.WfCompleted--        it "discovers unfinished workflows from the instance table" $ \storeHandle -> do-            counter <- newIORef (0 :: Int)-            let completedName = WorkflowName "discover-completed"-                cancelledName = WorkflowName "discover-cancelled"-                crashedName = WorkflowName "discover-crashed"-                rotatedName = WorkflowName "discover-rotated"-            Right (Completed _) <--                Store.runStoreIO storeHandle $-                    runWorkflow completedName (WorkflowId "done") (demoWorkflow counter)-            cancelledAt <- getCurrentTime-            Right () <--                Store.runStoreIO storeHandle $-                    appendJournalEntry cancelledName (WorkflowId "cancelled") (WorkflowCancelled cancelledAt)-            Left (_ :: SimulatedCrash) <--                try $-                    Store.runStoreIO storeHandle $-                        runWorkflow crashedName (WorkflowId "crashed") (crashAfterStep1 counter)-            Right ContinuedAsNew <--                Store.runStoreIO storeHandle $-                    runWorkflow rotatedName (WorkflowId "rotated") (rollingTotal counter 1 2)-            now <- getCurrentTime-            Right unfinished <- Store.runStoreIO storeHandle (findUnfinishedWorkflowIds now)-            unfinished-                `shouldBe` [ ("crashed", "discover-crashed")-                           , ("rotated", "discover-rotated")-                           ]--    describe "Keiro.Workflow snapshots" $ around (withFreshStore fixture) $ do-        it "does not fail committed workflow steps when snapshot writes fail" $ \storeHandle -> do-            (exporter, metricsRef) <- inMemoryMetricExporter-            (provider, _env) <--                createMeterProvider-                    emptyMaterializedResources-                    defaultSdkMeterProviderOptions{metricExporter = Just exporter}-            meter <- getMeter provider Telemetry.keiroInstrumentationLibrary-            keiroMetrics <- Telemetry.newKeiroMetrics meter-            let opts =-                    defaultWorkflowRunOptions-                        & #snapshotPolicy-                        .~ Every 2-                        & #metrics-                        ?~ keiroMetrics-            Right () <--                Store.runStoreIO storeHandle $-                    Store.runTransaction $-                        Tx.sql "ALTER TABLE keiro.keiro_snapshots ADD CONSTRAINT keiro_snapshots_no_writes CHECK (false) NOT VALID"-            counter <- newIORef (0 :: Int)-            result <--                Store.runStoreIO storeHandle $-                    runWorkflowWith opts (WorkflowName "snap-write-failure") (WorkflowId "wf1") (countingSixSteps counter)-            result `shouldBe` Right (Completed [1, 2, 3, 4, 5, 6])-            Right journal <--                Store.runStoreIO storeHandle $-                    Store.readStreamForward (StreamName "wf:snap-write-failure-wf1") (StreamVersion 0) 100-            Vector.length journal `shouldBe` 7-            Right snapshotVersionDuringFailure <--                Store.runStoreIO storeHandle $-                    Store.runTransaction $-                        Tx.statement "wf:snap-write-failure-wf1" snapshotVersionForStreamStmt-            snapshotVersionDuringFailure `shouldBe` Nothing-            _ <- forceFlushMeterProvider provider Nothing-            exported <- readIORef metricsRef-            lookup "keiro.snapshot.write.failures" (flattenScalarPoints exported) `shouldBe` Just (IntNumber 3)-            Right () <--                Store.runStoreIO storeHandle $-                    Store.runTransaction $-                        Tx.sql "ALTER TABLE keiro.keiro_snapshots DROP CONSTRAINT keiro_snapshots_no_writes"-            recoveryCounter <- newIORef (0 :: Int)-            recovery <--                Store.runStoreIO storeHandle $-                    runWorkflowWith opts (WorkflowName "snap-write-recovery") (WorkflowId "wf2") (countingSixSteps recoveryCounter)-            recovery `shouldBe` Right (Completed [1, 2, 3, 4, 5, 6])-            Right snapshotVersionAfterRecovery <--                Store.runStoreIO storeHandle $-                    Store.runTransaction $-                        Tx.statement "wf:snap-write-recovery-wf2" snapshotVersionForStreamStmt-            snapshotVersionAfterRecovery `shouldBe` Just (StreamVersion 6)--        -- Validation (a): a snapshot row appears at the expected version and-        -- decodes to the full accumulated step map.-        it "writes a snapshot of the accumulated step map after Every 2 fires" $ \storeHandle -> do-            counter <- newIORef (0 :: Int)-            let name = WorkflowName "snap"-                wid = WorkflowId "w1"-            result <--                Store.runStoreIO storeHandle $-                    runWorkflowWith-                        (defaultWorkflowRunOptions & #snapshotPolicy .~ Every 2)-                        name-                        wid-                        (countingSixSteps counter)-            result `shouldBe` Right (Completed [1, 2, 3, 4, 5, 6])-            -- Every 2 fired at versions 2, 4, 6; the upsert keeps the highest (6).-            Right snapVersion <--                Store.runStoreIO storeHandle $-                    Store.runTransaction $-                        Tx.statement "wf:snap-w1" snapshotVersionForStreamStmt-            snapVersion `shouldBe` Just (StreamVersion 6)-            -- and the row decodes to the six-entry accumulated map.-            Right mSeed <- Store.runStoreIO storeHandle $ loadWorkflowSnapshot (StreamName "wf:snap-w1")-            case mSeed of-                Just (m, v) -> do-                    v `shouldBe` StreamVersion 6-                    Map.keys m `shouldBe` ["s1", "s2", "s3", "s4", "s5", "s6"]-                Nothing -> expectationFailure "expected a workflow snapshot row"--        -- The OnTerminal completion-site wiring: only the final WorkflowCompleted-        -- append (version 7) triggers the snapshot.-        it "writes a terminal snapshot under OnTerminal at the completion version" $ \storeHandle -> do-            counter <- newIORef (0 :: Int)-            let name = WorkflowName "term"-                wid = WorkflowId "tm1"-            result <--                Store.runStoreIO storeHandle $-                    runWorkflowWith-                        (defaultWorkflowRunOptions & #snapshotPolicy .~ OnTerminal)-                        name-                        wid-                        (countingSixSteps counter)-            result `shouldBe` Right (Completed [1, 2, 3, 4, 5, 6])-            Right snapVersion <--                Store.runStoreIO storeHandle $-                    Store.runTransaction $-                        Tx.statement "wf:term-tm1" snapshotVersionForStreamStmt-            snapVersion `shouldBe` Just (StreamVersion 7)--        -- Validation (b): re-hydration reads only the tail after the snapshot-        -- version, and the journaled steps short-circuit (the counter stays put).-        it "reads only the tail after the snapshot version on re-hydration" $ \storeHandle -> do-            counter <- newIORef (0 :: Int)-            let name = WorkflowName "tail"-                wid = WorkflowId "t1"-                opts = defaultWorkflowRunOptions & #snapshotPolicy .~ Every 2-            first <- Store.runStoreIO storeHandle $ runWorkflowWith opts name wid (countingSixSteps counter)-            first `shouldBe` Right (Completed [1, 2, 3, 4, 5, 6])-            afterFirst <- readIORef counter-            afterFirst `shouldBe` 6-            -- A full version-0 replay would read every journal event...-            Right full <--                Store.runStoreIO storeHandle $-                    Store.readStreamForward (StreamName "wf:tail-t1") (StreamVersion 0) 100-            Vector.length full `shouldBe` 7 -- six StepRecorded + one WorkflowCompleted-            -- ...whereas the runtime seeds from the snapshot and reads only the tail.-            Right (Just (seedMap, StreamVersion sv)) <--                Store.runStoreIO storeHandle $ loadWorkflowSnapshot (StreamName "wf:tail-t1")-            Map.size seedMap `shouldBe` 6-            Right tailEvents <--                Store.runStoreIO storeHandle $-                    Store.readStreamForward (StreamName "wf:tail-t1") (StreamVersion sv) 100-            Vector.length tailEvents `shouldSatisfy` (< Vector.length full)-            Vector.length tailEvents `shouldBe` 1 -- only the WorkflowCompleted at v7-            -- Re-hydration completes from the seed without re-running any step.-            second <- Store.runStoreIO storeHandle $ runWorkflowWith opts name wid (countingSixSteps counter)-            second `shouldBe` Right (Completed [1, 2, 3, 4, 5, 6])-            afterSecond <- readIORef counter-            afterSecond `shouldBe` 6--        -- Validation (c): a Never run and an Every 2 run produce identical results-        -- and identical journals, and the snapshot seed equals a full replay.-        it "produces identical results and journals under Never and Every 2" $ \storeHandle -> do-            counterN <- newIORef (0 :: Int)-            counterE <- newIORef (0 :: Int)-            neverRes <--                Store.runStoreIO storeHandle $-                    runWorkflowWith-                        (defaultWorkflowRunOptions & #snapshotPolicy .~ Never)-                        (WorkflowName "corr-never")-                        (WorkflowId "c1")-                        (countingSixSteps counterN)-            everyRes <--                Store.runStoreIO storeHandle $-                    runWorkflowWith-                        (defaultWorkflowRunOptions & #snapshotPolicy .~ Every 2)-                        (WorkflowName "corr-every")-                        (WorkflowId "c1")-                        (countingSixSteps counterE)-            neverRes `shouldBe` Right (Completed [1, 2, 3, 4, 5, 6])-            everyRes `shouldBe` Right (Completed [1, 2, 3, 4, 5, 6])-            Right neverEvents <--                Store.runStoreIO storeHandle $-                    Store.readStreamForward (StreamName "wf:corr-never-c1") (StreamVersion 0) 100-            Right everyEvents <--                Store.runStoreIO storeHandle $-                    Store.readStreamForward (StreamName "wf:corr-every-c1") (StreamVersion 0) 100-            let stepResults evs =-                    [ (k, v)-                    | Right (StepRecorded k v _) <- decodeRecorded workflowJournalCodec <$> Vector.toList evs-                    ]-            stepResults neverEvents `shouldBe` stepResults everyEvents-            -- The snapshot seed equals the map a full version-0 replay would fold.-            Right (Just (seedMap, _)) <--                Store.runStoreIO storeHandle $ loadWorkflowSnapshot (StreamName "wf:corr-every-c1")-            seedMap `shouldBe` Map.fromList (stepResults everyEvents)--        -- Validation (d): an advisory snapshot whose discriminant no longer matches-        -- is ignored and the workflow hydrates via full replay.-        it "hydrates via full replay when the snapshot discriminant mismatches" $ \storeHandle -> do-            counter <- newIORef (0 :: Int)-            let name = WorkflowName "dmiss"-                wid = WorkflowId "d1"-                opts = defaultWorkflowRunOptions & #snapshotPolicy .~ Every 2-            _ <- Store.runStoreIO storeHandle $ runWorkflowWith opts name wid (countingSixSteps counter)-            Right () <--                Store.runStoreIO storeHandle $-                    Store.runTransaction $-                        Tx.statement ("wf:dmiss-d1", "stale-shape") corruptSnapshotShapeStmt-            Right mSeed <- Store.runStoreIO storeHandle $ loadWorkflowSnapshot (StreamName "wf:dmiss-d1")-            mSeed `shouldBe` Nothing-            resumed <- Store.runStoreIO storeHandle $ runWorkflowWith opts name wid (countingSixSteps counter)-            resumed `shouldBe` Right (Completed [1, 2, 3, 4, 5, 6])--        -- Validation (d), second arm: corrupt snapshot JSON is treated as a miss.-        it "hydrates via full replay when the snapshot JSON is corrupt" $ \storeHandle -> do-            (exporter, metricsRef) <- inMemoryMetricExporter-            (provider, _env) <--                createMeterProvider-                    emptyMaterializedResources-                    defaultSdkMeterProviderOptions{metricExporter = Just exporter}-            meter <- getMeter provider Telemetry.keiroInstrumentationLibrary-            keiroMetrics <- Telemetry.newKeiroMetrics meter-            counter <- newIORef (0 :: Int)-            let name = WorkflowName "cjson"-                wid = WorkflowId "d2"-                opts =-                    defaultWorkflowRunOptions-                        & #snapshotPolicy-                        .~ Every 2-                        & #metrics-                        ?~ keiroMetrics-            _ <- Store.runStoreIO storeHandle $ runWorkflowWith opts name wid (countingSixSteps counter)-            Right () <--                Store.runStoreIO storeHandle $-                    Store.runTransaction $-                        Tx.statement ("wf:cjson-d2", Aeson.String "bad") corruptSnapshotStateStmt-            Right mSeed <- Store.runStoreIO storeHandle $ loadWorkflowSnapshot (StreamName "wf:cjson-d2")-            mSeed `shouldBe` Nothing-            resumed <- Store.runStoreIO storeHandle $ runWorkflowWith opts name wid (countingSixSteps counter)-            resumed `shouldBe` Right (Completed [1, 2, 3, 4, 5, 6])-            _ <- forceFlushMeterProvider provider Nothing-            exported <- readIORef metricsRef-            let scalars = flattenScalarPoints exported-            lookup "keiro.snapshot.decode.failures" scalars `shouldBe` Just (IntNumber 1)-            lookup "keiro.snapshot.read.misses" scalars `shouldBe` Just (IntNumber 2)--    describe "Keiro.Workflow 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-                    , resumed = 1-                    , completed = 1-                    , stillSuspended = 0-                    , unknownName = 0-                    , failed = 0-                    , transientErrors = 0-                    , leaseSkipped = 0-                    }-            -- Step 1 short-circuited; steps 2 and 3 ran exactly once.-            readIORef counter >>= \c -> c `shouldBe` 3-            -- The journal now holds s1, s2, s3, WorkflowCompleted.-            Right recorded <--                Store.runStoreIO storeHandle $-                    Store.readStreamForward (StreamName "wf:crash-demo-cd-1") (StreamVersion 0) 10-            traverse (decodeRecorded workflowJournalCodec) (Vector.toList recorded)-                `shouldSatisfy` \case-                    Right [StepRecorded "s1" _ _, StepRecorded "s2" _ _, StepRecorded "s3" _ _, WorkflowCompleted _] -> True-                    _ -> False-            -- A second pass discovers nothing — the workflow is finished.-            Right summary2 <--                Store.runStoreIO storeHandle $ resumeWorkflowsOnce defaultWorkflowResumeOptions registry-            summary2 `shouldBe` emptyResumeSummary--        -- M3: a workflow suspended on an awaited step is driven to Completed once-        -- that step is journaled (here simulated; an EP-39/EP-40 wake source would-        -- journal the same StepRecorded end to end).-        it "resumes a suspended workflow once its awaited step is journaled" $ \storeHandle -> do-            counter <- newIORef (0 :: Int)-            let name = WorkflowName "await-demo"-                wid = WorkflowId "ad-1"-            suspended <--                Store.runStoreIO storeHandle $ runWorkflow name wid (awaitingThenStep counter)-            suspended `shouldBe` Right Suspended-            -- Simulate the wake source resolving the await.-            Right () <- Store.runStoreIO storeHandle $ do-                now <- liftIO getCurrentTime-                appendJournalEntry name wid (StepRecorded "awk:approval" (toJSON ("ok" :: Text)) now)-            let registry = Map.singleton name (WorkflowDef (\_wid -> awaitingThenStep counter))-            Right summary <--                Store.runStoreIO storeHandle $ resumeWorkflowsOnce defaultWorkflowResumeOptions registry-            summary-                `shouldBe` ResumeSummary-                    { discovered = 1-                    , resumed = 1-                    , completed = 1-                    , stillSuspended = 0-                    , unknownName = 0-                    , failed = 0-                    , transientErrors = 0-                    , leaseSkipped = 0-                    }-            readIORef counter >>= \c -> c `shouldBe` 1-            Right recorded <--                Store.runStoreIO storeHandle $-                    Store.readStreamForward (StreamName "wf:await-demo-ad-1") (StreamVersion 0) 10-            traverse (decodeRecorded workflowJournalCodec) (Vector.toList recorded)-                `shouldSatisfy` \case-                    Right [StepRecorded "awk:approval" _ _, StepRecorded "use" _ _, WorkflowCompleted _] -> True-                    _ -> False--        -- M4: a discovered workflow whose name is absent from the registry is-        -- skipped and counted, never silently dropped or fatal.-        it "skips and counts a workflow whose name is absent from the registry" $ \storeHandle -> do-            counter <- newIORef (0 :: Int)-            let name = WorkflowName "orphan"-                wid = WorkflowId "or-1"-            crashed <--                try-                    ( Store.runStoreIO storeHandle $-                        runWorkflow name wid (crashAfterStep1 counter)-                    ) ::-                    IO (Either SomeException (Either Store.StoreError (WorkflowOutcome (Int, Int, Int))))-            case crashed of-                Left _ -> pure ()-                Right other -> expectationFailure ("expected a simulated crash, got " <> show other)-            -- Empty registry: the orphan is surfaced via unknownName, not completed.-            Right summary <--                Store.runStoreIO storeHandle $ resumeWorkflowsOnce defaultWorkflowResumeOptions Map.empty-            summary-                `shouldBe` ResumeSummary-                    { discovered = 1-                    , resumed = 0-                    , completed = 0-                    , stillSuspended = 0-                    , unknownName = 1-                    , failed = 0-                    , transientErrors = 0-                    , leaseSkipped = 0-                    }-            -- The journal is unchanged: still one step, no completion.-            Right recorded <--                Store.runStoreIO storeHandle $-                    Store.readStreamForward (StreamName "wf:orphan-or-1") (StreamVersion 0) 10-            Vector.length recorded `shouldBe` 1--        it "isolates a poison workflow so a healthy workflow still completes" $ \storeHandle -> do-            healthyCounter <- newIORef (0 :: Int)-            let poisonName = WorkflowName "poison"-                poisonId = WorkflowId "poison-1"-                healthyName = WorkflowName "healthy"-                healthyId = WorkflowId "healthy-1"-                opts =-                    defaultWorkflowResumeOptions-                        & #maxAttempts-                        .~ 1-                        & #logEvent-                        .~ const (pure ())-                registry =-                    Map.fromList-                        [ (poisonName, WorkflowDef (\_ -> liftIO (throwIO SimulatedCrash) *> pure (0 :: Int)))-                        , (healthyName, WorkflowDef (\_ -> threeStep healthyCounter))-                        ]-            now <- getCurrentTime-            Right () <--                Store.runStoreIO storeHandle $-                    appendJournalEntry poisonName poisonId (StepRecorded "seed" (toJSON True) now)-            crashed <--                try-                    ( Store.runStoreIO storeHandle $-                        runWorkflow healthyName healthyId (crashAfterStep1 healthyCounter)-                    ) ::-                    IO (Either SomeException (Either Store.StoreError (WorkflowOutcome (Int, Int, Int))))-            case crashed of-                Left _ -> pure ()-                Right other -> expectationFailure ("expected a simulated crash, got " <> show other)-            Right summary <- Store.runStoreIO storeHandle $ resumeWorkflowsOnce opts registry-            summary-                `shouldBe` emptyResumeSummary-                    { discovered = 2-                    , resumed = 2-                    , completed = 1-                    , failed = 1-                    }-            readIORef healthyCounter >>= \c -> c `shouldBe` 3-            Right (Just poisonRow) <- Store.runStoreIO storeHandle $ Instance.lookupInstance poisonName poisonId-            poisonRow ^. #status `shouldBe` Instance.WfFailed--        it "marks a crashing workflow failed and short-circuits later direct runs" $ \storeHandle -> do-            let name = WorkflowName "terminal-poison"-                wid = WorkflowId "tp-1"-                opts =-                    defaultWorkflowResumeOptions-                        & #maxAttempts-                        .~ 1-                        & #logEvent-                        .~ const (pure ())-                registry = Map.singleton name (WorkflowDef (\_ -> liftIO (throwIO SimulatedCrash) *> pure (0 :: Int)))-            now <- getCurrentTime-            Right () <--                Store.runStoreIO storeHandle $-                    appendJournalEntry name wid (StepRecorded "seed" (toJSON True) now)-            Right summary <- Store.runStoreIO storeHandle $ resumeWorkflowsOnce opts registry-            failed summary `shouldBe` 1-            Right (Just row) <- Store.runStoreIO storeHandle $ Instance.lookupInstance name wid-            row ^. #status `shouldBe` Instance.WfFailed-            row ^. #attempts `shouldBe` 1-            direct <- Store.runStoreIO storeHandle $ runWorkflow name wid (step (StepName "never") (pure (1 :: Int)))-            direct `shouldBe` Right Failed-            Right recordedFailed <--                Store.runStoreIO storeHandle $-                    Store.readStreamForward (StreamName "wf:terminal-poison-tp-1") (StreamVersion 0) 10-            traverse (decodeRecorded workflowJournalCodec) (Vector.toList recordedFailed)-                `shouldSatisfy` \case-                    Right events -> any (\case WorkflowFailed{} -> True; _ -> False) events-                    _ -> False--        it "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` True-            Right claimedB <- Store.runStoreIO storeHandle $ Instance.claimInstance "owner-b" 30 name wid-            claimedB `shouldBe` False-            Right () <- Store.runStoreIO storeHandle $ Instance.releaseInstance "owner-a" False name wid-            Right claimedBAfterRelease <- Store.runStoreIO storeHandle $ Instance.claimInstance "owner-b" 30 name wid-            claimedBAfterRelease `shouldBe` True--        it "lets an expired workflow lease be taken and resets attempts on progressed release" $ \storeHandle -> do-            let name = WorkflowName "lease-expire"-                wid = WorkflowId "le-1"-            Right claimedA <- Store.runStoreIO storeHandle $ Instance.claimInstance "owner-a" 30 name wid-            claimedA `shouldBe` True-            Right attempt <--                Store.runStoreIO storeHandle $-                    Store.runTransaction $-                        Instance.recordCrashTx "le-1" "lease-expire" "boom"-            attempt `shouldBe` 1-            Right () <--                Store.runStoreIO storeHandle $-                    Store.runTransaction $-                        Tx.sql "UPDATE keiro.keiro_workflows SET lease_expires_at = now() - interval '1 second', next_attempt_at = now() - interval '1 second' WHERE workflow_id = 'le-1' AND workflow_name = 'lease-expire'"-            Right claimedB <- Store.runStoreIO storeHandle $ Instance.claimInstance "owner-b" 30 name wid-            claimedB `shouldBe` True-            Right () <- Store.runStoreIO storeHandle $ Instance.releaseInstance "owner-b" True name wid-            Right (Just row) <- Store.runStoreIO storeHandle $ Instance.lookupInstance name wid-            row ^. #attempts `shouldBe` 0-            row ^. #lastError `shouldBe` Nothing-            row ^. #nextAttemptAt `shouldBe` Nothing-            row ^. #leasedBy `shouldBe` Nothing--        it "skips a resume candidate held by another live lease owner" $ \storeHandle -> do-            ran <- newIORef False-            let name = WorkflowName "lease-skip"-                wid = WorkflowId "ls-1"-                registry =-                    Map.singleton name $-                        WorkflowDef-                            ( \_ -> do-                                liftIO (writeIORef ran True)-                                pure (0 :: Int)-                            )-            now <- getCurrentTime-            Right () <--                Store.runStoreIO storeHandle $-                    appendJournalEntry name wid (StepRecorded "seed" (toJSON True) now)-            Right foreignClaim <- Store.runStoreIO storeHandle $ Instance.claimInstance "foreign-owner" 30 name wid-            foreignClaim `shouldBe` True-            Right summary <- Store.runStoreIO storeHandle $ resumeWorkflowsOnce defaultWorkflowResumeOptions registry-            summary-                `shouldBe` emptyResumeSummary-                    { discovered = 1-                    , leaseSkipped = 1-                    }-            readIORef ran `shouldReturn` False--        -- M4: resume on an already-completed workflow is a genuine no-op.-        it "discovers nothing for an already-completed workflow and is stable" $ \storeHandle -> do-            counter <- newIORef (0 :: Int)-            let name = WorkflowName "done-demo"-                wid = WorkflowId "dd-1"-            done <- Store.runStoreIO storeHandle $ runWorkflow name wid (threeStep counter)-            done `shouldBe` Right (Completed (1, 2, 3))-            readIORef counter >>= \c -> c `shouldBe` 3-            let registry = Map.singleton name (WorkflowDef (\_wid -> threeStep counter))-            Right summary1 <--                Store.runStoreIO storeHandle $ resumeWorkflowsOnce defaultWorkflowResumeOptions registry-            summary1 `shouldBe` emptyResumeSummary-            Right summary2 <--                Store.runStoreIO storeHandle $ resumeWorkflowsOnce defaultWorkflowResumeOptions registry-            summary2 `shouldBe` emptyResumeSummary-            readIORef counter >>= \c -> c `shouldBe` 3--    describe "Keiro.Workflow 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-            Right claimedA <- Store.runStoreIO storeHandle $ Instance.claimInstance "owner-a" 0.2 name wid-            claimedA `shouldBe` True-            outcome <- Store.runStoreIO storeHandle $ runWorkflowWith runOpts name wid body-            outcome `shouldBe` Right (Completed False)-            readIORef attemptedClaim `shouldReturn` Just False-            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` True-            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-            Right () <--                Store.runStoreIO store $-                    Store.runTransaction $-                        Tx.sql "ALTER TABLE keiro.keiro_workflow_steps RENAME TO keiro_workflow_steps_hidden"-            worker <- forkIO (runWorkflowResumeWorkerPush store opts registry)-            logged <- waitForPassFailure-            logged `shouldBe` Just ()-            Right () <--                Store.runStoreIO store $-                    Store.runTransaction $-                        Tx.sql "ALTER TABLE keiro.keiro_workflow_steps_hidden RENAME TO keiro_workflow_steps"-            now <- getCurrentTime-            Right () <--                Store.runStoreIO store $-                    appendJournalEntry name wid (StepRecorded "awk:gate" (toJSON ()) now)-            resumed <- timeout 5_000_000 (takeMVar done)-            status <- threadStatus worker-            killThread worker-            resumed `shouldBe` Just ()-            status `shouldSatisfy` \case-                ThreadFinished -> False-                ThreadDied -> False-                _ -> True--    describe "Keiro.Workflow push fallback (EP-50)" $ around (withFreshStore fixture) $ do-        -- Push is strictly an optimization: with the worker on 'neverWake' (every-        -- NOTIFY dropped) and a small fallback, the gated workflow still drains on-        -- the durable poll.-        it "still drains on the fallback timeout when no notification is delivered" $ \store -> do-            done <- newEmptyMVar-            let name = WorkflowName "fallbackwf"-                wid = WorkflowId "f-1"-                registry = Map.singleton name (WorkflowDef (\_ -> gateThenSignal done))-                onePass = void (Store.runStoreIO store (resumeWorkflowsOnce defaultWorkflowResumeOptions registry))-            first <- Store.runStoreIO store (runWorkflow name wid (gateThenSignal done))-            first `shouldBe` Right Suspended-            worker <- forkIO (runPollLoopWith neverWake 200000 onePass) -- 200 ms fallback, no notifications-            now <- getCurrentTime-            Right () <--                Store.runStoreIO store $-                    appendJournalEntry name wid (StepRecorded "awk:gate" (toJSON ()) now)-            resumed <- timeout 5000000 (takeMVar done)-            killThread worker-            resumed `shouldBe` Just ()--    describe "Shard lease" $ around (withFreshStore fixture) $ do-        -- EP-51 M2: claim / renew / release / expiry at the SQL layer, with explicit-        -- `now` timestamps standing in for the passage of time (no workers yet). The-        -- exclusion guarantee is the FOR UPDATE SKIP LOCKED claim; disjointness and-        -- failover are both observable purely from the lease table.-        let subName = SubscriptionName "orders-shard"-            wA = WorkerId sampleUuid-            wB = WorkerId sampleUuid2-            ttl = 30 :: NominalDiffTime-            t0 = UTCTime (ModifiedJulianDay 60000) (secondsToDiffTime 0)-            tExpired = addUTCTime 60 t0 -- past A's 30 s lease-            shardOpts = defaultShardedWorkerOptions (Category (CategoryName "orders")) 4-        it "validates sharded worker options before startup" $ \_store -> do-            shouldBeRight_ (mkShardedWorkerOptions shardOpts)-            mkShardedWorkerOptions (shardOpts & #shardCount .~ 0)-                `shouldBeLeft` InvalidShardCount 0-            mkShardedWorkerOptions (shardOpts & #leaseTtl .~ 0)-                `shouldBeLeft` InvalidShardLeaseTtl 0-            mkShardedWorkerOptions (shardOpts & #renewInterval .~ 0)-                `shouldBeLeft` InvalidShardRenewInterval 0-            mkShardedWorkerOptions (shardOpts & #leaseTtl .~ 10 & #renewInterval .~ 10)-                `shouldBeLeft` InvalidShardLeaseRenewInterval 10 10-            mkShardedWorkerOptions (shardOpts & #batchSize .~ 0)-                `shouldBeLeft` InvalidShardBatchSize 0-            mkShardedWorkerOptions (shardOpts & #bufferSize .~ 0)-                `shouldBeLeft` InvalidShardBufferSize 0-            mkShardedWorkerOptions (shardOpts & #handlerRetryDelay .~ KirokuSub.RetryDelay (-1))-                `shouldBeLeft` InvalidShardHandlerRetryDelay (KirokuSub.RetryDelay (-1))-            mkShardedWorkerOptions (shardOpts & #retryPolicy .~ KirokuSub.RetryPolicy 0)-                `shouldBeLeft` InvalidShardRetryMaxAttempts 0--        it "ensureShardRows populates N rows once (idempotent on re-run)" $ \store -> do-            Right () <- Store.runStoreIO store $ Store.runTransaction $ do-                ensureShardRows subName 4-                ensureShardRows subName 4-            Right rows <- Store.runStoreIO store $ Store.runTransaction (listShardOwnership subName)-            map (\(b, _, _) -> b) rows `shouldBe` [0, 1, 2, 3]-            all (\(_, o, _) -> isNothing o) rows `shouldBe` True--        it "worker A claims all N when free; B claims 0 while A holds valid leases" $ \store -> do-            Right claimedA <- Store.runStoreIO store $ Store.runTransaction $ do-                ensureShardRows subName 4-                claimShardsTx subName wA 4 t0 ttl-            claimedA `shouldBe` [0, 1, 2, 3]-            Right claimedB <- Store.runStoreIO store $ Store.runTransaction (claimShardsTx subName wB 4 t0 ttl)-            claimedB `shouldBe` []--        it "B claims A's buckets after A's lease expires; A then renews nothing" $ \store -> do-            Right _ <- Store.runStoreIO store $ Store.runTransaction $ do-                ensureShardRows subName 4-                claimShardsTx subName wA 4 t0 ttl-            Right claimedB <- Store.runStoreIO store $ Store.runTransaction (claimShardsTx subName wB 4 tExpired ttl)-            claimedB `shouldBe` [0, 1, 2, 3]-            -- A lost every bucket to B, so its renew returns the empty set: this is how-            -- a worker learns it no longer owns a bucket and stops reading it.-            Right heldA <- Store.runStoreIO store $ Store.runTransaction (renewLeaseTx subName wA tExpired ttl)-            heldA `shouldBe` []--        it "renewLease returns only still-held buckets" $ \store -> do-            Right held <- Store.runStoreIO store $ Store.runTransaction $ do-                ensureShardRows subName 4-                _ <- claimShardsTx subName wA 4 t0 ttl-                renewLeaseTx subName wA t0 ttl-            held `shouldBe` [0, 1, 2, 3]--        it "releaseShards: relinquished buckets are immediately claimable" $ \store -> do-            Right _ <- Store.runStoreIO store $ Store.runTransaction $ do-                ensureShardRows subName 4-                _ <- claimShardsTx subName wA 4 t0 ttl-                releaseShardsTx subName wA [0, 1]-            -- Even while A's lease over 2,3 is still valid, the released 0,1 are claimable.-            Right claimedB <- Store.runStoreIO store $ Store.runTransaction (claimShardsTx subName wB 4 t0 ttl)-            claimedB `shouldBe` [0, 1]--        it "fairShareTarget divides buckets evenly (ceil)" $ \_store -> do-            fairShareTarget 6 3 `shouldBe` 2-            fairShareTarget 6 4 `shouldBe` 2-            fairShareTarget 7 3 `shouldBe` 3-            fairShareTarget 4 0 `shouldBe` 4 -- a non-positive estimate claims everything-        it "acquireOutcome keeps previous ownership on acquire failure" $ \_store -> do-            let previous = Set.fromList [0, 2]-            acquireOutcome previous (Left "database unavailable")-                `shouldBe` (previous, Just (ShardAcquireFailed "database unavailable"))-            acquireOutcome previous (Right (Set.fromList [1, 3]))-                `shouldBe` (Set.fromList [1, 3], Nothing)--        it "ensureShards rejects a shardCount mismatch" $ \store -> do-            let lease4 =-                    ShardLease-                        { subscriptionName = subName-                        , workerId = wA-                        , shardCount = 4-                        , leaseTtl = ttl-                        }-                lease6 =-                    ShardLease-                        { subscriptionName = subName-                        , workerId = wA-                        , shardCount = 6-                        , leaseTtl = ttl-                        }-            Right () <- Store.runStoreIO store (ensureShards lease4)-            Store.runStoreIO store (ensureShards lease6)-                `shouldThrow` \case-                    ShardCountMismatch name configured found ->-                        name == "orders-shard" && configured == 6 && found == [4]--    describe "Sharded subscription single worker" $ around (withFreshStore fixture) $ do-        -- EP-51 M3: one process owning all N buckets drains a seeded category exactly-        -- once. The sink is idempotent on event_id, so "count == total" proves every-        -- event was delivered with none missing and none surviving as a duplicate row.-        it "one worker with N=4 buckets drains a seeded category exactly once" $ \store -> do-            Right () <- Store.runStoreIO store $ Store.runTransaction (Tx.sql createShardSinkSql)-            total <- seedOrders store 8 5 -- 40 events across 8 streams-            let opts =-                    (defaultShardedWorkerOptions (Category (CategoryName "orders")) 4)-                        { leaseTtl = 3-                        , renewInterval = 0.3-                        }-            w <- forkIO (runShardedSubscriptionGroup store (SubscriptionName "orders-sub") opts (sinkHandler store 1))-            drained <- waitUntilSinkCount store total 20_000_000-            killThread w-            drained `shouldBe` True-            count <- shardSinkCount store-            count `shouldBe` total-            maxW <- maxWorkersPerStream store-            maxW `shouldBe` 1--    describe "Sharded subscription drain and failover" $ around (withFreshStore fixture) $ do-        -- EP-51 M5: the behavioural acceptance. Three worker processes cooperatively-        -- partition a category; we let ownership converge on the *empty* category-        -- first (so the churn of cold-start rebalancing touches no events), then seed-        -- and drain under stable membership — so each stream is owned by exactly one-        -- worker throughout the drain. Then we kill a worker and prove its buckets are-        -- re-homed and the new events drain (failover via lease expiry).-        let sub = SubscriptionName "orders-failover"-            mkOpts = (defaultShardedWorkerOptions (Category (CategoryName "orders")) 6){leaseTtl = 3, renewInterval = 0.3}-        it "three workers drain disjointly, then re-home a killed worker's buckets" $ \store -> do-            Right () <- Store.runStoreIO store $ Store.runTransaction (Tx.sql createShardSinkSql)-            w1 <- forkIO (runShardedSubscriptionGroup store sub mkOpts (sinkHandler store 1))-            w2 <- forkIO (runShardedSubscriptionGroup store sub mkOpts (sinkHandler store 2))-            w3 <- forkIO (runShardedSubscriptionGroup store sub mkOpts (sinkHandler store 3))-            -- Wait for cooperative balance on the empty category: all 6 buckets owned,-            -- spread across >= 2 workers, none holding more than its fair share.-            balanced <- waitShardsBalanced store sub 6 2 15_000_000-            balanced `shouldBe` True-            -- Now seed and drain under stable membership.-            total1 <- seedOrders store 12 5 -- 60 events-            ok1 <- waitUntilSinkCount store total1 25_000_000-            ok1 `shouldBe` True-            -- Disjoint: no stream key was processed by two workers (stable membership,-            -- so no re-homing split any stream).-            maxW <- maxWorkersPerStream store-            maxW `shouldBe` 1-            -- The work genuinely spread (not a monopoly): at least two workers participated.-            spread <- distinctWorkers store-            spread `shouldSatisfy` (>= 2)-            -- Counts sum to total with no duplicate event id (PK on event_id + count).-            c1 <- shardSinkCount store-            c1 `shouldBe` total1-            -- Kill worker 1 (its readers stop; it stops renewing, so its leases expire).-            killThread w1-            -- Seed more across all streams; some hash to worker 1's now-orphaned buckets.-            total2 <- seedOrders store 12 5 -- another 60-            -- Failover: a surviving worker re-claims the expired buckets and drains the-            -- new events. If re-homing did not happen, events on worker 1's buckets would-            -- never drain and this would time out.-            ok2 <- waitUntilSinkCount store (total1 + total2) 30_000_000-            killThread w2-            killThread w3-            ok2 `shouldBe` True-            c2 <- shardSinkCount store-            c2 `shouldBe` (total1 + total2)--        it "a killed worker relinquishes its leases immediately" $ \store -> do-            let subImmediate = SubscriptionName "orders-immediate-release"-                longTtlOpts =-                    (defaultShardedWorkerOptions (Category (CategoryName "orders")) 4)-                        { leaseTtl = 30-                        , renewInterval = 0.2-                        }-            w <- forkIO (runShardedSubscriptionGroup store subImmediate longTtlOpts (sinkHandler store 1))-            owned <- waitShardsBalanced store subImmediate 4 1 10_000_000-            owned `shouldBe` True-            killThread w-            released <- waitShardsUnowned store subImmediate 4 3_000_000-            released `shouldBe` True--        it "a handler exception is retried in place and drains" $ \store -> do-            Right () <- Store.runStoreIO store $ Store.runTransaction (Tx.sql createShardSinkSql)-            thrown <- newIORef False-            errors <- newIORef []-            let subRestart = SubscriptionName "orders-reader-restart"-                opts =-                    (defaultShardedWorkerOptions (Category (CategoryName "orders")) 2)-                        { leaseTtl = 3-                        , renewInterval = 0.2-                        , handlerRetryDelay = KirokuSub.RetryDelay 0.05-                        , onShardError = Just (\err -> modifyIORef' errors (err :))-                        }-                handler ev = do-                    firstTime <--                        atomicModifyIORef'-                            thrown-                            ( \seen ->-                                if seen-                                    then (seen, False)-                                    else (True, True)-                            )-                    when firstTime (throwIO (userError "reader boom"))-                    sinkHandler store 1 ev-            w <- forkIO (runShardedSubscriptionGroup store subRestart opts handler)-            balanced <- waitShardsBalanced store subRestart 2 1 10_000_000-            balanced `shouldBe` True-            total <- seedOrders store 4 2-            drained <- waitUntilSinkCount store total 20_000_000-            killThread w-            drained `shouldBe` True-            seenErrors <- readIORef errors-            seenErrors `shouldSatisfy` all (\case ShardReaderDied _ _ -> False; _ -> True)--    describe "Sharded subscription ack coupling" $ around (withFreshStore fixture) $ do-        it "redelivers a batch-tail event whose handler was killed mid-flight" $ \store -> do-            Right () <- Store.runStoreIO store $ Store.runTransaction (Tx.sql createShardSinkSql)-            total <- seedOrders store 1 5-            enteredTail <- newEmptyMVar-            holdTail <- newEmptyMVar-            let sub = SubscriptionName "orders-ack-tail"-                opts =-                    (defaultShardedWorkerOptions (Category (CategoryName "orders")) 1)-                        { leaseTtl = 3-                        , renewInterval = 0.3-                        }-                blockingHandler ev = do-                    let orderNumber = parseEither (withObject "OrderPlaced" (.: "n")) (ev ^. #payload)-                    when (orderNumber == Right (4 :: Int)) $ do-                        putMVar enteredTail ()-                        takeMVar holdTail-                    sinkHandler store 1 ev-            first <- forkIO (runShardedSubscriptionGroup store sub opts blockingHandler)-            entered <- timeout 10_000_000 (takeMVar enteredTail)-            entered `shouldBe` Just ()-            -- The old pull bridge replies Continue before invoking the handler;-            -- leave enough time for its batch-tail checkpoint to commit while the-            -- handler remains blocked. The ack-coupled bridge introduced by EP-96-            -- remains blocked on the unfilled reply instead.-            threadDelay 200_000-            killThread first-            second <- forkIO (runShardedSubscriptionGroup store sub opts (sinkHandler store 2))-            drained <- waitUntilSinkCount store total 20_000_000-            killThread second-            drained `shouldBe` True-            shardSinkCount store `shouldReturn` total--        it "loses no events when a bucket is shed mid-drain during rebalance" $ \store -> do-            Right () <- Store.runStoreIO store $ Store.runTransaction (Tx.sql createShardSinkSql)-            total <- seedOrders store 24 5-            let sub = SubscriptionName "orders-ack-rebalance"-                opts =-                    (defaultShardedWorkerOptions (Category (CategoryName "orders")) 4)-                        { leaseTtl = 3-                        , renewInterval = 0.3-                        , batchSize = 1-                        }-                slowHandler tag ev = do-                    threadDelay 100_000-                    sinkHandler store tag ev-            first <- forkIO (runShardedSubscriptionGroup store sub opts (slowHandler 1))-            -- acquireOwnedBuckets claims one bucket per pass. Starting the joiner-            -- while A owns three leaves one claimable bucket for B, making B visible;-            -- A's next pass then sheds its excess third bucket while its handler is-            -- deliberately slow and in flight.-            ownsThree <- waitUntilOwnedShardCount store sub 3 10_000_000-            ownsThree `shouldBe` True-            second <- forkIO (runShardedSubscriptionGroup store sub opts (slowHandler 2))-            drained <- waitUntilSinkCount store total 30_000_000-            killThread first-            killThread second-            drained `shouldBe` True-            shardSinkCount store `shouldReturn` total--        it "allows zombie overlap duplicates without losing an event" $ \store -> do-            Right () <- Store.runStoreIO store $ Store.runTransaction (Tx.sql createShardSinkSql)-            total <- seedOrders store 1 5-            entered <- newEmptyMVar-            release <- newEmptyMVar-            deliveries <- newIORef ([] :: [EventId])-            successor <- newIORef Nothing-            readersA <- newIORef Map.empty-            let sub = SubscriptionName "orders-ack-zombie"-                opts =-                    (defaultShardedWorkerOptions (Category (CategoryName "orders")) 1)-                        { leaseTtl = 2-                        , renewInterval = 0.2-                        }-                leaseA =-                    ShardLease-                        { subscriptionName = sub-                        , workerId = WorkerId sampleUuid-                        , shardCount = 1-                        , leaseTtl = 2-                        }-                handlerA delivery = do-                    let ev = delivery ^. #event-                    modifyIORef' deliveries ((ev ^. #eventId) :)-                    putMVar entered ()-                    takeMVar release-                    sinkHandler store 1 ev-                    pure ShardAckOk-                handlerB delivery = do-                    let ev = delivery ^. #event-                    modifyIORef' deliveries ((ev ^. #eventId) :)-                    sinkHandler store 2 ev-                    pure ShardAckOk-                cleanup = do-                    void (tryPutMVar release ())-                    mSuccessor <- readIORef successor-                    for_ mSuccessor killThread-                    now <- getCurrentTime-                    let cleanupWorker = WorkerId sampleUuid2-                    _ <- Store.runStoreIO store $ Store.runTransaction $ do-                        releaseShardsTx sub (WorkerId sampleUuid) [0]-                        claimShardsTx sub cleanupWorker 1 now 30-                    void (reconcileShardsOnce store leaseA opts readersA handlerA)-            ( do-                    Right () <- Store.runStoreIO store (ensureShards leaseA)-                    void (reconcileShardsOnce store leaseA opts readersA handlerA)-                    timeout 10_000_000 (takeMVar entered) `shouldReturn` Just ()-                    -- A no longer renews, but its reader remains alive and blocked-                    -- with one unacknowledged event. B can claim after expiry and-                    -- must therefore receive that event again from the checkpoint.-                    threadDelay 2_500_000-                    workerB <- forkIO (runShardedSubscriptionGroupAck store sub opts handlerB)-                    writeIORef successor (Just workerB)-                    drained <- waitUntilSinkCount store total 20_000_000-                    drained `shouldBe` True-                    raw <- readIORef deliveries-                    length raw `shouldSatisfy` (> total)-                    shardSinkCount store `shouldReturn` total-                )-                `finally` cleanup--        it "dead-letters a poison event after bounded retries and keeps draining" $ \store -> do-            Right () <- Store.runStoreIO store $ Store.runTransaction (Tx.sql createShardSinkSql)-            total <- seedOrders store 1 4-            poisonDeliveries <- newIORef (0 :: Int)-            errors <- newIORef []-            let sub = SubscriptionName "orders-ack-poison"-                opts =-                    (defaultShardedWorkerOptions (Category (CategoryName "orders")) 1)-                        { leaseTtl = 3-                        , renewInterval = 0.2-                        , handlerRetryDelay = KirokuSub.RetryDelay 0.05-                        , retryPolicy = KirokuSub.RetryPolicy 3-                        , onShardError = Just (\err -> modifyIORef' errors (err :))-                        }-                handler ev = do-                    let orderNumber = parseEither (withObject "OrderPlaced" (.: "n")) (ev ^. #payload)-                    if orderNumber == Right (1 :: Int)-                        then do-                            modifyIORef' poisonDeliveries (+ 1)-                            throwIO (userError "poison order")-                        else sinkHandler store 1 ev-            worker <- forkIO (runShardedSubscriptionGroup store sub opts handler)-            drained <- waitUntilSinkCount store (total - 1) 20_000_000-            details <- shardDeadLetterDetails store "orders-ack-poison"-            attempts <- readIORef poisonDeliveries-            seenErrors <- readIORef errors-            killThread worker-            drained `shouldBe` True-            attempts `shouldBe` 3-            details `shouldBe` (1, Just "max retry attempts exceeded (3)", Just 3)-            seenErrors `shouldSatisfy` all (\case ShardReaderDied _ _ -> False; _ -> True)--    describe "Keiro.Workflow observability" $ around (withFreshStore fixture) $ do-        -- The headline operability signal: executed (real work) vs replayed-        -- (recorded history), recorded by the runtime through an SDK meter and read-        -- back from the in-memory exporter — plus the active gauge and the-        -- journal-length histogram.-        it "records workflow instruments through an SDK meter" $ \storeHandle -> do-            (exporter, ref) <- inMemoryMetricExporter-            (provider, _env) <--                createMeterProvider-                    emptyMaterializedResources-                    defaultSdkMeterProviderOptions{metricExporter = Just exporter}-            meter <- getMeter provider Telemetry.keiroInstrumentationLibrary-            metrics <- Telemetry.newKeiroMetrics meter-            counter <- newIORef (0 :: Int)-            let name = WorkflowName "obs"-                wid = WorkflowId "obs-1"-                opts = defaultWorkflowRunOptions & #metrics .~ Just metrics-            -- First run: both steps miss → two executions.-            first <- Store.runStoreIO storeHandle $ runWorkflowWith opts name wid (demoWorkflow counter)-            first `shouldBe` Right (Completed (1, 2))-            -- Second run, same id: both steps hit → two replays.-            second <- Store.runStoreIO storeHandle $ runWorkflowWith opts name wid (demoWorkflow counter)-            second `shouldBe` Right (Completed (1, 2))-            -- The side effects ran exactly twice across both runs (the replay run-            -- short-circuited every step).-            readIORef counter >>= \c -> c `shouldBe` 2-            _ <- forceFlushMeterProvider provider Nothing-            exported <- readIORef ref-            let scalars = flattenScalarPoints exported-                hists = flattenHistogramPoints exported-            lookup "keiro.workflow.steps.executed" scalars `shouldBe` Just (IntNumber 2)-            lookup "keiro.workflow.steps.replayed" scalars `shouldBe` Just (IntNumber 2)-            -- One journal-length observation per completed run (two completions).-            [c | (n, c, _) <- hists, n == "keiro.workflow.journal.length"] `shouldBe` [2]-            -- Both runs finished, so the live-run count returned to zero.-            lookup "keiro.workflow.active" scalars `shouldBe` Just (IntNumber 0)--        -- The resume worker increments keiro.workflow.resumed per re-invocation and-        -- samples keiro.workflow.awakeables.pending each pass.-        it "records a resume and the pending-awakeable count when the worker re-invokes" $ \storeHandle -> do-            (exporter, ref) <- inMemoryMetricExporter-            (provider, _env) <--                createMeterProvider-                    emptyMaterializedResources-                    defaultSdkMeterProviderOptions{metricExporter = Just exporter}-            meter <- getMeter provider Telemetry.keiroInstrumentationLibrary-            metrics <- Telemetry.newKeiroMetrics meter-            counter <- newIORef (0 :: Int)-            let name = WorkflowName "obs-resume"-                wid = WorkflowId "obs-r-1"-            -- Suspend a workflow so it has a step row but no completion: the resume-            -- worker will re-invoke it (and stay Suspended, which still counts as a-            -- re-invocation).-            suspended <- Store.runStoreIO storeHandle $ runWorkflow name wid (stepThenAwaitWorkflow counter)-            suspended `shouldBe` Right Suspended-            -- Register one pending awakeable (independent of the suspended workflow's-            -- own await) so the pending gauge has something to count.-            let aid = awakeableIdToUuid (deterministicAwakeableId (WorkflowName "ext") (WorkflowId "1") "cb")-            Right () <--                Store.runStoreIO storeHandle $ Store.runTransaction $ Awk.registerAwakeableTx aid "ext" "1"-            -- One resume pass with metrics threaded through the run options.-            let registry = Map.singleton name (WorkflowDef (\_wid -> stepThenAwaitWorkflow counter))-                resumeOpts =-                    defaultWorkflowResumeOptions-                        & #runOptions-                        .~ (defaultWorkflowRunOptions & #metrics .~ Just metrics)-            Right _summary <- Store.runStoreIO storeHandle $ resumeWorkflowsOnce resumeOpts registry-            _ <- forceFlushMeterProvider provider Nothing-            exported <- readIORef ref-            let scalars = flattenScalarPoints exported-            lookup "keiro.workflow.resumed" scalars `shouldBe` Just (IntNumber 1)-            lookup "keiro.workflow.awakeables.pending" scalars `shouldBe` Just (IntNumber 1)--        -- The no-op idiom end to end: defaultWorkflowRunOptions carries metrics =-        -- Nothing, so a run on a dedicated provider exports no points at all.-        it "records nothing through a Nothing handle" $ \storeHandle -> do-            (exporter, ref) <- inMemoryMetricExporter-            (provider, _env) <--                createMeterProvider-                    emptyMaterializedResources-                    defaultSdkMeterProviderOptions{metricExporter = Just exporter}-            counter <- newIORef (0 :: Int)-            result <--                Store.runStoreIO storeHandle $-                    runWorkflow (WorkflowName "obs-noop") (WorkflowId "obs-n-1") (demoWorkflow counter)-            result `shouldBe` Right (Completed (1, 2))-            _ <- forceFlushMeterProvider provider Nothing-            exported <- readIORef ref-            flattenScalarPoints exported `shouldBe` []-            flattenHistogramPoints exported `shouldBe` []--    describe "Keiro.Workflow.Snapshot codec" $ do-        -- Pure (no-DB) round-trip of the workflow state codec.-        it "round-trips a non-trivial accumulated step map and carries the sentinel shape hash" $ do-            let m =-                    Map.fromList-                        [ ("first", toJSON (1 :: Int))-                        , ("second", toJSON ["a", "b" :: Text])-                        , ("sleep:42", Aeson.Null)-                        ]-            (workflowStateCodec ^. #decode) ((workflowStateCodec ^. #encode) m) `shouldBe` Right m-            (workflowStateCodec ^. #shapeHash) `shouldBe` "keiro.workflow.stepmap.v1"-            (workflowStateCodec ^. #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.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.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.Awakeable" $ do-        -- Pure (no-DB) check of the deterministic id derivation.-        it "derives a deterministic AwakeableId, stable across calls and label-sensitive" $ do-            let aid1 = deterministicAwakeableId (WorkflowName "w") (WorkflowId "1") "approval"-                aid2 = deterministicAwakeableId (WorkflowName "w") (WorkflowId "1") "approval"-                aidOther = deterministicAwakeableId (WorkflowName "w") (WorkflowId "1") "other"-                awakeableGolden = uuidLiteral "ccaeaf74-3ffe-5ea5-a118-a3441a95c279"-            aid1 `shouldBe` aid2-            (aid1 == aidOther) `shouldBe` False-            aid1 `shouldBe` AwakeableId awakeableGolden--        around (withFreshStore fixture) $ do-            it "schema: registers, completes once (idempotent), cancels, and counts pending rows" $ \storeHandle -> do-                let aidA = awakeableIdToUuid (deterministicAwakeableId (WorkflowName "sch") (WorkflowId "1") "a")-                    aidB = awakeableIdToUuid (deterministicAwakeableId (WorkflowName "sch") (WorkflowId "1") "b")-                now <- getCurrentTime-                Right () <- Store.runStoreIO storeHandle $ Store.runTransaction $ do-                    Awk.registerAwakeableTx aidA "sch" "1"-                    Awk.registerAwakeableTx aidB "sch" "1"-                Right pendingCount <- Store.runStoreIO storeHandle Awk.countPendingAwakeables-                pendingCount `shouldBe` 2-                Right (Just rowA) <- Store.runStoreIO storeHandle $ Awk.lookupAwakeable aidA-                rowA ^. #status `shouldBe` Awk.Pending-                rowA ^. #payload `shouldBe` Nothing-                -- Complete A once; the status-guarded UPDATE makes a re-complete a no-op.-                Right firstComplete <--                    Store.runStoreIO storeHandle $-                        Store.runTransaction $-                            Awk.completeAwakeableTx aidA (toJSON ("done" :: Text)) now-                firstComplete `shouldBe` True-                Right secondComplete <--                    Store.runStoreIO storeHandle $-                        Store.runTransaction $-                            Awk.completeAwakeableTx aidA (toJSON ("again" :: Text)) now-                secondComplete `shouldBe` False-                Right (Just rowA') <- Store.runStoreIO storeHandle $ Awk.lookupAwakeable aidA-                rowA' ^. #status `shouldBe` Awk.Completed-                rowA' ^. #payload `shouldBe` Just (toJSON ("done" :: Text))-                -- Cancel the still-pending B; both rows are now resolved.-                Right cancelled <--                    Store.runStoreIO storeHandle $-                        Store.runTransaction $-                            Awk.cancelAwakeableTx aidB-                cancelled `shouldBe` True-                Right pendingAfter <- Store.runStoreIO storeHandle Awk.countPendingAwakeables-                pendingAfter `shouldBe` 0--            it "suspends on an unsignalled awakeable, recording a pending row and no completion" $ \storeHandle -> do-                aidRef <- newIORef Nothing-                let name = WorkflowName "approval"-                    wid = WorkflowId "wf1"-                outcome1 <- Store.runStoreIO storeHandle $ runWorkflow name wid (approvalFlowWithId aidRef)-                outcome1 `shouldBe` Right Suspended-                aid <- readRequiredAwakeableId aidRef-                Right (Just row) <- Store.runStoreIO storeHandle $ Awk.lookupAwakeable (awakeableIdToUuid aid)-                row ^. #status `shouldBe` Awk.Pending-                row ^. #payload `shouldBe` Nothing-                Right pendingNow <- Store.runStoreIO storeHandle Awk.countPendingAwakeables-                pendingNow `shouldBe` 1-                Right recorded <--                    Store.runStoreIO storeHandle $-                        Store.readStreamForward (StreamName "wf:approval-wf1") (StreamVersion 0) 100-                traverse (decodeRecorded workflowJournalCodec) (Vector.toList recorded)-                    `shouldSatisfy` \case-                        Right [StepRecorded stepName value _] ->-                            stepName == awakeableAllocStepPrefix <> "approval" && value == toJSON aid-                        _ -> False--            it "resumes with the signalled payload after signalAwakeable" $ \storeHandle -> do-                aidRef <- newIORef Nothing-                let name = WorkflowName "approval"-                    wid = WorkflowId "wf1"-                Right Suspended <- Store.runStoreIO storeHandle $ runWorkflow name wid (approvalFlowWithId aidRef)-                aid <- readRequiredAwakeableId aidRef-                let awkStep = "awk:" <> awakeableIdText aid-                Right signalled <- Store.runStoreIO storeHandle $ signalAwakeable aid ("ok" :: Text)-                signalled `shouldBe` True-                Right (Just row) <- Store.runStoreIO storeHandle $ Awk.lookupAwakeable (awakeableIdToUuid aid)-                row ^. #status `shouldBe` Awk.Completed-                row ^. #payload `shouldBe` Just (toJSON ("ok" :: Text))-                Right afterSignal <--                    Store.runStoreIO storeHandle $-                        Store.readStreamForward (StreamName "wf:approval-wf1") (StreamVersion 0) 100-                traverse (decodeRecorded workflowJournalCodec) (Vector.toList afterSignal)-                    `shouldSatisfy` \case-                        Right [StepRecorded allocStep _ _, StepRecorded s r _] ->-                            allocStep == awakeableAllocStepPrefix <> "approval" && s == awkStep && r == toJSON ("ok" :: Text)-                        _ -> False-                outcome2 <- Store.runStoreIO storeHandle $ runWorkflow name wid (approvalFlowWithId aidRef)-                outcome2 `shouldBe` Right (Completed "ok!")-                Right afterResume <--                    Store.runStoreIO storeHandle $-                        Store.readStreamForward (StreamName "wf:approval-wf1") (StreamVersion 0) 100-                traverse (decodeRecorded workflowJournalCodec) (Vector.toList afterResume)-                    `shouldSatisfy` \case-                        Right [StepRecorded allocStep _ _, StepRecorded s1 _ _, StepRecorded "use" _ _, WorkflowCompleted _] ->-                            allocStep == awakeableAllocStepPrefix <> "approval" && s1 == awkStep-                        _ -> False--            it "is idempotent: a second signal returns False and does not change the value" $ \storeHandle -> do-                aidRef <- newIORef Nothing-                let name = WorkflowName "idem"-                    wid = WorkflowId "wf-i"-                Right Suspended <- Store.runStoreIO storeHandle $ runWorkflow name wid (approvalFlowWithId aidRef)-                aid <- readRequiredAwakeableId aidRef-                let awkStep = "awk:" <> awakeableIdText aid-                Right True <- Store.runStoreIO storeHandle $ signalAwakeable aid ("ok" :: Text)-                Right again <- Store.runStoreIO storeHandle $ signalAwakeable aid ("later" :: Text)-                again `shouldBe` False-                Right (Just row) <- Store.runStoreIO storeHandle $ Awk.lookupAwakeable (awakeableIdToUuid aid)-                row ^. #payload `shouldBe` Just (toJSON ("ok" :: Text))-                Right recorded <--                    Store.runStoreIO storeHandle $-                        Store.readStreamForward (StreamName "wf:idem-wf-i") (StreamVersion 0) 100-                Right decoded <- pure (traverse (decodeRecorded workflowJournalCodec) (Vector.toList recorded))-                [r | StepRecorded s r _ <- decoded, s == awkStep] `shouldBe` [toJSON ("ok" :: Text)]--            it "throws WorkflowAwakeableCancelled after cancelAwakeable" $ \storeHandle -> do-                aidRef <- newIORef Nothing-                let name = WorkflowName "cancelwf"-                    wid = WorkflowId "wf2"-                Right Suspended <- Store.runStoreIO storeHandle $ runWorkflow name wid (approvalFlowWithId aidRef)-                aid <- readRequiredAwakeableId aidRef-                Right cancelled <- Store.runStoreIO storeHandle $ cancelAwakeable aid-                cancelled `shouldBe` True-                Right (Just row) <- Store.runStoreIO storeHandle $ Awk.lookupAwakeable (awakeableIdToUuid aid)-                row ^. #status `shouldBe` Awk.Cancelled-                Store.runStoreIO storeHandle (runWorkflow name wid (approvalFlowWithId aidRef))-                    `shouldThrow` (== WorkflowAwakeableCancelled aid)-                Right recorded <--                    Store.runStoreIO storeHandle $-                        Store.readStreamForward (StreamName "wf:cancelwf-wf2") (StreamVersion 0) 100-                Right decoded <- pure (traverse (decodeRecorded workflowJournalCodec) (Vector.toList recorded))-                any (\case WorkflowCompleted{} -> True; _ -> False) decoded `shouldBe` False--            it "re-appends a missing journal entry when re-signalled (crash-safe)" $ \storeHandle -> do-                aidRef <- newIORef Nothing-                let name = WorkflowName "crash"-                    wid = WorkflowId "wf3"-                Right Suspended <- Store.runStoreIO storeHandle $ runWorkflow name wid (approvalFlowWithId aidRef)-                aid <- readRequiredAwakeableId aidRef-                let awkStep = "awk:" <> awakeableIdText aid-                -- Simulate "row completed but the journal append did not happen" by-                -- completing the row directly, bypassing signalAwakeable's journal write.-                now <- getCurrentTime-                Right completedRow <--                    Store.runStoreIO storeHandle $-                        Store.runTransaction $-                            Awk.completeAwakeableTx (awakeableIdToUuid aid) (toJSON ("ok" :: Text)) now-                completedRow `shouldBe` True-                Right beforeRepair <--                    Store.runStoreIO storeHandle $-                        Store.readStreamForward (StreamName "wf:crash-wf3") (StreamVersion 0) 100-                Right beforeDecoded <- pure (traverse (decodeRecorded workflowJournalCodec) (Vector.toList beforeRepair))-                [() | StepRecorded s _ _ <- beforeDecoded, s == awkStep] `shouldBe` []-                -- A re-signal with the same payload returns False (already completed) but-                -- repairs the missing journal entry from the stored payload.-                Right repaired <- Store.runStoreIO storeHandle $ signalAwakeable aid ("ok" :: Text)-                repaired `shouldBe` False-                Right afterRepair <--                    Store.runStoreIO storeHandle $-                        Store.readStreamForward (StreamName "wf:crash-wf3") (StreamVersion 0) 100-                Right afterDecoded <- pure (traverse (decodeRecorded workflowJournalCodec) (Vector.toList afterRepair))-                [r | StepRecorded s r _ <- afterDecoded, s == awkStep] `shouldBe` [toJSON ("ok" :: Text)]--            it "repairs a completed awakeable row from the await arm without a second signal" $ \storeHandle -> do-                aidRef <- newIORef Nothing-                let name = WorkflowName "crash-arm"-                    wid = WorkflowId "wf4"-                Right Suspended <- Store.runStoreIO storeHandle $ runWorkflow name wid (approvalFlowWithId aidRef)-                aid <- readRequiredAwakeableId aidRef-                let awkStep = "awk:" <> awakeableIdText aid-                now <- getCurrentTime-                Right True <--                    Store.runStoreIO storeHandle $-                        Store.runTransaction $-                            Awk.completeAwakeableTx (awakeableIdToUuid aid) (toJSON ("ok" :: Text)) now-                repairedRun <- Store.runStoreIO storeHandle $ runWorkflow name wid (approvalFlowWithId aidRef)-                repairedRun `shouldBe` Right Suspended-                Right repairedJournal <--                    Store.runStoreIO storeHandle $-                        Store.readStreamForward (StreamName "wf:crash-arm-wf4") (StreamVersion 0) 100-                Right repairedDecoded <- pure (traverse (decodeRecorded workflowJournalCodec) (Vector.toList repairedJournal))-                [r | StepRecorded s r _ <- repairedDecoded, s == awkStep] `shouldBe` [toJSON ("ok" :: Text)]-                completed <- Store.runStoreIO storeHandle $ runWorkflow name wid (approvalFlowWithId aidRef)-                completed `shouldBe` Right (Completed "ok!")--            it "refuses a forged coordinate-derived id for a fresh awakeable" $ \storeHandle -> do-                aidRef <- newIORef Nothing-                let name = WorkflowName "fresh-awake"-                    wid = WorkflowId "fa-1"-                    forged = deterministicAwakeableId name wid "approval"-                Right Suspended <- Store.runStoreIO storeHandle $ runWorkflow name wid (approvalFlowWithId aidRef)-                real <- readRequiredAwakeableId aidRef-                real `shouldNotBe` forged-                Right forgedSignal <- Store.runStoreIO storeHandle $ signalAwakeable forged ("bad" :: Text)-                forgedSignal `shouldBe` False-                Right stillSuspended <- Store.runStoreIO storeHandle $ runWorkflow name wid (approvalFlowWithId aidRef)-                stillSuspended `shouldBe` Suspended-                Right realSignal <- Store.runStoreIO storeHandle $ signalAwakeable real ("ok" :: Text)-                realSignal `shouldBe` True-                completed <- Store.runStoreIO storeHandle $ runWorkflow name wid (approvalFlowWithId aidRef)-                completed `shouldBe` Right (Completed "ok!")--            it "adopts a generation-0 legacy deterministic row" $ \storeHandle -> do-                aidRef <- newIORef Nothing-                let name = WorkflowName "legacy-awake"-                    wid = WorkflowId "la-1"-                    legacy = deterministicAwakeableId name wid "approval"-                Right () <--                    Store.runStoreIO storeHandle $-                        Store.runTransaction $-                            Awk.registerAwakeableTx (awakeableIdToUuid legacy) (unWorkflowName name) (unWorkflowId wid)-                Right Suspended <- Store.runStoreIO storeHandle $ runWorkflow name wid (approvalFlowWithId aidRef)-                adopted <- readRequiredAwakeableId aidRef-                adopted `shouldBe` legacy-                Right True <- Store.runStoreIO storeHandle $ signalAwakeable legacy ("ok" :: Text)-                completed <- Store.runStoreIO storeHandle $ runWorkflow name wid (approvalFlowWithId aidRef)-                completed `shouldBe` Right (Completed "ok!")--            it "allocates a fresh awakeable for the same label after continueAsNew" $ \storeHandle -> do-                idsRef <- newIORef []-                let name = WorkflowName "awake-roll"-                    wid = WorkflowId "ar-1"-                    body = rollingAwakeableWorkflow idsRef-                Right Suspended <- Store.runStoreIO storeHandle $ runWorkflow name wid body-                ids1 <- readIORef idsRef-                [firstAid] <- pure ids1-                Right True <- Store.runStoreIO storeHandle $ signalAwakeable firstAid ("first" :: Text)-                Right ContinuedAsNew <- Store.runStoreIO storeHandle $ runWorkflow name wid body-                Right Suspended <- Store.runStoreIO storeHandle $ runWorkflow name wid body-                ids2 <- readIORef idsRef-                case ids2 of-                    [firstAgain, secondAid] -> do-                        firstAgain `shouldBe` firstAid-                        secondAid `shouldNotBe` firstAid-                        Right staleSignal <- Store.runStoreIO storeHandle $ signalAwakeable firstAid ("stale" :: Text)-                        staleSignal `shouldBe` False-                        Right stillSuspended <- Store.runStoreIO storeHandle $ runWorkflow name wid body-                        stillSuspended `shouldBe` Suspended-                        Right True <- Store.runStoreIO storeHandle $ signalAwakeable secondAid ("second" :: Text)-                        completed <- Store.runStoreIO storeHandle $ runWorkflow name wid body-                        completed `shouldBe` Right (Completed "second")-                    other -> expectationFailure ("expected two awakeable ids, got " <> show other)--    describe "Keiro.Workflow 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--{- | 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.-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 <> "!"))--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)--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 ())---- | A two-step child workflow used in the child-workflow tests.-shipWorkflow :: (Workflow :> es) => Eff es Text-shipWorkflow = do-    a <- step (StepName "pack") (pure ("packed" :: Text))-    b <- step (StepName "label") (pure (a <> "+labelled"))-    pure b--{- | A parent that spawns a @"ship"@ child (id supplied), awaits its result, and-then records a @notify@ step. Parametrised by child id so each test isolates-its own child journal.--}-parentWorkflow :: (Workflow :> es, Store :> es, IOE :> es) => WorkflowId -> Eff es Text-parentWorkflow childWid = do-    h <- spawnChild (WorkflowName "ship") childWid shipWorkflow-    result <- awaitChild h-    _ <- step (StepName "notify") (pure ("done:" <> result))-    pure ("done:" <> result)--jsonObjectChildWorkflow :: Eff es Aeson.Value-jsonObjectChildWorkflow =-    pure (object ["cancelled" Aeson..= True])--jsonObjectParentWorkflow :: (Workflow :> es, Store :> es, IOE :> es) => WorkflowId -> Eff es Aeson.Value-jsonObjectParentWorkflow childWid = do-    h <- spawnChild (WorkflowName "json-child") childWid jsonObjectChildWorkflow-    result <- awaitChild h-    _ <- step (StepName "json-notify") (pure ())-    pure result--selfCancellingWorkflow :: (Workflow :> es, Store :> es, IOE :> es) => WorkflowName -> WorkflowId -> IORef Int -> Eff es Int-selfCancellingWorkflow name wid counter = do-    _ <- step (StepName "one") (liftIO (incrementAndRead counter))-    _ <--        step (StepName "two") $ do-            now <- liftIO getCurrentTime-            appendJournalEntry name wid (WorkflowCancelled now)-            liftIO (incrementAndRead counter)-    step (StepName "three") (liftIO (incrementAndRead counter))--nominalDays :: Int -> NominalDiffTime-nominalDays n = fromIntegral n * 86400--attrKeyText :: AttributeKey Text -> Text-attrKeyText = unkey--attrKeyTextInt64 :: AttributeKey Int64 -> Text-attrKeyTextInt64 = unkey--textAttr :: Attributes -> Text -> Maybe Text-textAttr attrs name = case lookupAttribute attrs name of-    Just (AttributeValue (TextAttribute t)) -> Just t-    _ -> Nothing--intAttr :: Attributes -> Text -> Maybe Int64-intAttr attrs name = case lookupAttribute attrs name of-    Just (AttributeValue (IntAttribute n)) -> Just n-    _ -> Nothing--{- | A frozen snapshot of an 'ImmutableSpan'. In hs-opentelemetry 1.0 the-mutable span fields (name, attributes, status) live behind the-@spanHot :: IORef SpanHot@ field rather than directly on 'ImmutableSpan',-so the tests read that reference once after the span ends and assert on-this flat record.--}-data CapturedSpan = CapturedSpan-    { csName :: Text-    , csKind :: SpanKind-    , csAttributes :: Attributes-    , csStatus :: SpanStatus-    , csContext :: SpanContext-    , csParent :: Maybe Span-    }--captureSpan :: ImmutableSpan -> IO CapturedSpan-captureSpan sp = do-    hot <- readIORef (spanHot sp)-    pure-        CapturedSpan-            { csName = hotName hot-            , csKind = spanKind sp-            , csAttributes = hotAttributes hot-            , csStatus = hotStatus hot-            , csContext = spanContext sp-            , csParent = spanParent sp-            }--{- | Tiny in-process \"Kafka topic\": an MVar of consumed records plus an-incrementing offset. The publisher pushes records here; the consumer-drains the MVar. There is no real broker — the goal of the fixture is-to validate that the keiro envelope and outbox/inbox semantics-compose correctly across two isolated PostgreSQL contexts.--}-newtype KafkaTopic = KafkaTopic (MVar (Int64, [InboxKafka.KafkaInboundRecord]))--newKafkaTopic :: IO KafkaTopic-newKafkaTopic = KafkaTopic <$> newMVar (0, [])--kafkaTopicAccept :: (MonadIO m) => KafkaTopic -> OutboxRow -> m ()-kafkaTopicAccept (KafkaTopic ref) row = liftIO $ do-    let record = OutboxKafka.outboxRowToKafkaRecord row-        headersText =-            [ (TE.decodeUtf8 name, TE.decodeUtf8 value)-            | (name, value) <- record ^. #headers-            ]-    now <- getCurrentTime-    modifyMVar ref $ \(nextOffset, acc) ->-        let inbound =-                InboxKafka.KafkaInboundRecord-                    { topic = record ^. #topic-                    , partition = 0-                    , offset = nextOffset-                    , key = fmap TE.decodeUtf8 (record ^. #key)-                    , payload = record ^. #payload-                    , headers = headersText-                    , receivedAt = now-                    }-         in pure ((nextOffset + 1, inbound : acc), ())--kafkaTopicPublish ::-    forall es.-    (IOE :> es) =>-    KafkaTopic ->-    OutboxRow ->-    Eff es PublishOutcome-kafkaTopicPublish topic row = do-    kafkaTopicAccept topic row-    pure PublishSucceeded--perRow ::-    (OutboxRow -> Eff es PublishOutcome) ->-    [OutboxRow] ->-    Eff es [(OutboxId, PublishOutcome)]-perRow publish rows =-    traverse publishOne rows-  where-    publishOne row = do-        outcome <- publish row-        pure (row ^. #outboxId, outcome)--drainKafkaTopic :: KafkaTopic -> IO [InboxKafka.KafkaInboundRecord]-drainKafkaTopic (KafkaTopic ref) = do-    (_, acc) <- readMVar ref-    pure (reverse acc)--redeliverWithDifferentOffset ::-    InboxKafka.KafkaInboundRecord ->-    InboxKafka.KafkaInboundRecord-redeliverWithDifferentOffset record = record & #offset .~ (record ^. #offset) + 1000--data ConsumeResult a-    = ConsumeDecodeFailed !InboxKafka.KafkaDecodeError-    | ConsumePolicyUnsatisfied !InboxError-    | ConsumeApplied !(InboxResult a)-    deriving stock (Eq, Show)--{- | A worker-shaped consumer: decode the Kafka record into an-IntegrationEvent and run it through the inbox.--}-consumeAndApply ::-    forall es.-    (IOE :> es, Store :> es) =>-    InboxKafka.KafkaInboundRecord ->-    (IntegrationEvent -> Tx.Transaction ()) ->-    Eff es (ConsumeResult ())-consumeAndApply record handler =-    case InboxKafka.integrationEventFromKafka record of-        Left err -> pure (ConsumeDecodeFailed err)-        Right (event, kafkaRef) -> do-            result <--                runInboxTransaction Nothing PreferIntegrationMessageId event (Just kafkaRef) handler-            case result of-                Left err -> pure (ConsumePolicyUnsatisfied err)-                Right applied -> pure (ConsumeApplied applied)--billingReactionHandler :: IntegrationEvent -> Tx.Transaction ()-billingReactionHandler event = case decodeJsonIntegrationEvent event of-    Left _ -> Tx.condemn-    Right (OrderSubmittedPayload orderId quantity) ->-        Tx.statement (orderId, fromIntegral quantity :: Int64) insertReceivedOrderStmt--loggingReactionHandler :: Text -> IntegrationEvent -> Tx.Transaction ()-loggingReactionHandler _ event = do-    -- The cross-context test only needs the (eventType, key) pair, not-    -- the decoded payload.-    let key = fromMaybe "" (event ^. #key)-    Tx.statement (event ^. #source, event ^. #eventType, key) appendBillingEventLogStmt--insertReceivedOrderStmt :: Statement (Text, Int64) ()-insertReceivedOrderStmt =-    preparable-        """-        INSERT INTO billing_received_orders (order_id, quantity) VALUES ($1, $2)-        ON CONFLICT (order_id) DO NOTHING-        """-        ( contrazip2-            (E.param (E.nonNullable E.text))-            (E.param (E.nonNullable E.int8))-        )-        D.noResult--billingReceivedOrdersCountStmt :: Statement () Int-billingReceivedOrdersCountStmt =-    preparable-        "SELECT COUNT(*)::bigint FROM billing_received_orders"-        E.noParams-        (D.singleRow (fromIntegral <$> D.column (D.nonNullable D.int8)))--appendBillingEventLogStmt :: Statement (Text, Text, Text) ()-appendBillingEventLogStmt =-    preparable-        "INSERT INTO billing_event_log (source, event_type, order_id) VALUES ($1, $2, $3)"-        ( contrazip3-            (E.param (E.nonNullable E.text))-            (E.param (E.nonNullable E.text))-            (E.param (E.nonNullable E.text))-        )-        D.noResult--billingEventLogStmt :: Statement () [(Text, Text)]-billingEventLogStmt =-    preparable-        "SELECT event_type, order_id FROM billing_event_log ORDER BY seq"-        E.noParams-        ( D.rowList-            ( (,)-                <$> D.column (D.nonNullable D.text)-                <*> D.column (D.nonNullable D.text)-            )-        )--orderSubmittedEnvelope :: Text -> Int -> Text -> IntegrationEvent-orderSubmittedEnvelope orderId quantity messageId =-    encodeJsonIntegrationEvent-        ( sampleIntegrationEnvelope-            & #messageId-            .~ messageId-            & #eventType-            .~ "OrderSubmitted"-            & #key-            .~ Just orderId-        )-        (OrderSubmittedPayload orderId quantity)--orderCancelledEnvelope :: Text -> Text -> IntegrationEvent-orderCancelledEnvelope orderId messageId =-    sampleIntegrationEnvelope-        & #messageId-        .~ messageId-        & #eventType-        .~ "OrderCancelled"-        & #key-        .~ Just orderId-        & #payloadBytes-        .~ ("{\"orderId\":\"" <> TE.encodeUtf8 orderId <> "\"}")-        & #contentType-        .~ ApplicationJson--inboxTestCounterInsertStmt :: Statement Text ()-inboxTestCounterInsertStmt =-    preparable-        "INSERT INTO inbox_test_counter (message_id) VALUES ($1)"-        (E.param (E.nonNullable E.text))-        D.noResult--inboxTestCounterCountStmt :: Statement () Int-inboxTestCounterCountStmt =-    preparable-        "SELECT COUNT(*)::bigint FROM inbox_test_counter"-        E.noParams-        (D.singleRow (fromIntegral <$> D.column (D.nonNullable D.int8)))--sampleProducer :: IntegrationProducer ()-sampleProducer =-    IntegrationProducer-        { name = "ordering-integration-producer"-        , source = "ordering"-        , messageIdPrefix = "msg"-        , mapEvent = \_recorded () -> Just sampleDraft-        }--sampleDraft :: IntegrationEventDraft-sampleDraft =-    IntegrationEventDraft-        { destination = "billing.orders.v1"-        , key = Just "order-123"-        , eventType = "OrderSubmitted"-        , schemaVersion = 1-        , contentType = ApplicationJson-        , schemaReference = Nothing-        , sourceEventId = Nothing-        , sourceGlobalPosition = Nothing-        , payloadBytes = "{\"orderId\":\"order-123\",\"quantity\":5}"-        , occurredAt = UTCTime (ModifiedJulianDay 60000) (secondsToDiffTime 0)-        , causationId = Nothing-        , correlationId = Nothing-        , traceContext = Nothing-        , attributes = Just (object ["source" Aeson..= ("test-suite" :: Text)])-        }--sampleOutboxRow :: IntegrationEvent -> OutboxRow-sampleOutboxRow event =-    OutboxRow-        { outboxId = OutboxId outboxUuid1-        , event-        , status = OutboxPending-        , attemptCount = 0-        , nextAttemptAt = UTCTime (ModifiedJulianDay 60000) (secondsToDiffTime 0)-        , lastError = Nothing-        , publishedAt = Nothing-        , createdAt = UTCTime (ModifiedJulianDay 60000) (secondsToDiffTime 0)-        , updatedAt = UTCTime (ModifiedJulianDay 60000) (secondsToDiffTime 0)-        }--backdateOutboxUpdatedAt :: (Store :> es) => OutboxId -> UTCTime -> Eff es ()-backdateOutboxUpdatedAt oid timestamp =-    Store.runTransaction $-        Tx.statement (unOutboxId oid, timestamp) backdateOutboxUpdatedAtStmt--backdateOutboxUpdatedAtStmt :: Statement (UUID, UTCTime) ()-backdateOutboxUpdatedAtStmt =-    preparable-        "UPDATE keiro.keiro_outbox SET updated_at = $2 WHERE outbox_id = $1"-        ( contrazip2-            (E.param (E.nonNullable E.uuid))-            (E.param (E.nonNullable E.timestamptz))-        )-        D.noResult--backdateOutboxPublishedAt :: (Store :> es) => OutboxId -> UTCTime -> Eff es ()-backdateOutboxPublishedAt oid timestamp =-    Store.runTransaction $-        Tx.statement (unOutboxId oid, timestamp) backdateOutboxPublishedAtStmt--backdateOutboxPublishedAtStmt :: Statement (UUID, UTCTime) ()-backdateOutboxPublishedAtStmt =-    preparable-        "UPDATE keiro.keiro_outbox SET published_at = $2 WHERE outbox_id = $1"-        ( contrazip2-            (E.param (E.nonNullable E.uuid))-            (E.param (E.nonNullable E.timestamptz))-        )-        D.noResult--outboxUuid1, outboxUuid2, outboxUuid3, outboxUuid4 :: UUID-outboxUuid1 = case fromString "018f0f18-0000-7000-8000-000000000a01" of-    Just uuid -> uuid-    Nothing -> error "invalid outbox uuid 1"-outboxUuid2 = case fromString "018f0f18-0000-7000-8000-000000000a02" of-    Just uuid -> uuid-    Nothing -> error "invalid outbox uuid 2"-outboxUuid3 = case fromString "018f0f18-0000-7000-8000-000000000a03" of-    Just uuid -> uuid-    Nothing -> error "invalid outbox uuid 3"-outboxUuid4 = case fromString "018f0f18-0000-7000-8000-000000000a04" of-    Just uuid -> uuid-    Nothing -> error "invalid outbox uuid 4"--outboxIdFromOrdinal :: Word64 -> OutboxId-outboxIdFromOrdinal n =-    OutboxId (fromWords64 0x018f0f1800007000 (0x8000000000000000 + n))--uniqueIds :: (Eq a) => [a] -> [a]-uniqueIds = foldr (\x xs -> if x `elem` xs then xs else x : xs) []--data OrderSubmittedPayload = OrderSubmittedPayload-    { orderId :: !Text-    , quantity :: !Int-    }-    deriving stock (Generic, Eq, Show)--instance ToJSON OrderSubmittedPayload where-    toJSON = genericToJSON (aesonPrefix camelCase)-    toEncoding = genericToEncoding (aesonPrefix camelCase)--instance FromJSON OrderSubmittedPayload where-    parseJSON = genericParseJSON (aesonPrefix camelCase)--sampleIntegrationEnvelope :: IntegrationEvent-sampleIntegrationEnvelope =-    IntegrationEvent-        { messageId = "018f0f18-17aa-7000-8000-0000000000aa"-        , source = "ordering"-        , destination = "billing.orders.v1"-        , key = Just "order-123"-        , eventType = "OrderSubmitted"-        , schemaVersion = 1-        , contentType = ApplicationJson-        , schemaReference =-            Just-                SchemaReference-                    { registry = Just "https://schemas.example/registry"-                    , subject = Just "billing.orders.v1.OrderSubmitted"-                    , version = Just 1-                    , schemaId = Just 42-                    , fingerprint = Just "sha256:abc123"-                    }-        , sourceEventId = Just (EventId integrationSourceEventUuid)-        , sourceGlobalPosition = Just (GlobalPosition 42)-        , payloadBytes = "{\"orderId\":\"order-123\",\"quantity\":5}"-        , occurredAt = UTCTime (ModifiedJulianDay 60000) (secondsToDiffTime 0)-        , causationId = Just (EventId integrationCausationUuid)-        , correlationId = Just (EventId integrationCorrelationUuid)-        , traceContext =-            Just-                TraceContext-                    { traceparent = "00-0af7651916cd43dd8448eb211c80319c-b7ad6b7169203331-01"-                    , tracestate = Just "rojo=00f067aa0ba902b7"-                    }-        , attributes = Nothing-        }--integrationSourceEventUuid :: UUID-integrationSourceEventUuid =-    case fromString "018f0f18-17aa-7000-8000-000000000003" of-        Just uuid -> uuid-        Nothing -> error "invalid integration source event UUID"--integrationCausationUuid :: UUID-integrationCausationUuid =-    case fromString "018f0f18-17aa-7000-8000-000000000004" of-        Just uuid -> uuid-        Nothing -> error "invalid integration causation UUID"--integrationCorrelationUuid :: UUID-integrationCorrelationUuid =-    case fromString "018f0f18-17aa-7000-8000-000000000005" of-        Just uuid -> uuid-        Nothing -> error "invalid integration correlation UUID"--data OrderStream--data OrderEvent-    = OrderPlaced !Text !Int-    deriving stock (Generic, Eq, Show)--data OrderState-    = Idle-    deriving stock (Generic, Eq, Show)--data OrderCommand-    = PlaceOrder-    deriving stock (Generic, Eq, Show)--orderCodec :: Codec OrderEvent-orderCodec =-    Codec-        { eventTypes = EventType "OrderPlaced" :| []-        , eventType = \case-            OrderPlaced{} -> EventType "OrderPlaced"-        , schemaVersion = 2-        , encode = \case-            OrderPlaced orderId quantity ->-                object ["orderId" Aeson..= orderId, "quantity" Aeson..= quantity]-        , decode = parseOrderPlaced-        , upcasters = [(1, const upcastOrderPlacedV1)]-        }--gappyCodec :: Codec OrderEvent-gappyCodec =-    Codec-        { eventTypes = orderCodec ^. #eventTypes-        , eventType = orderCodec ^. #eventType-        , schemaVersion = 4-        , encode = orderCodec ^. #encode-        , decode = orderCodec ^. #decode-        , upcasters = [(1, const upcastOrderPlacedV1), (3, const Right)]-        }--parseOrderPlaced :: EventType -> Value -> Either Text OrderEvent-parseOrderPlaced _ value =-    case parseEither parser value of-        Right event -> Right event-        Left message -> Left (fromStringLiteral message)-  where-    parser = withObject "OrderPlaced" $ \objectValue ->-        OrderPlaced-            <$> objectValue .: "orderId"-            <*> objectValue .: "quantity"--upcastOrderPlacedV1 :: Value -> Either Text Value-upcastOrderPlacedV1 value =-    case parseEither parser value of-        Right migrated -> Right migrated-        Left message -> Left (fromStringLiteral message)-  where-    parser = withObject "OrderPlacedV1" $ \objectValue -> do-        orderId <- objectValue .: "orderId"-        quantity <- objectValue .: "qty"-        pure (object ["orderId" Aeson..= (orderId :: Text), "quantity" Aeson..= (quantity :: Int)])--metadataForOrDie :: Int -> Maybe Value -> Value-metadataForOrDie version existing =-    either (error . show) id (metadataFor version existing)--emptyTransducer :: SymTransducer () '[] OrderState OrderCommand OrderEvent-emptyTransducer =-    SymTransducer-        { edgesOut = \_ -> []-        , initial = Idle-        , initialRegs = RNil-        , isFinal = \_ -> True-        }--type CounterEventStream = EventStream (HsPred '[] CounterCommand) '[] CounterState CounterCommand CounterEvent--type ValidatedCounterEventStream = ValidatedEventStream (HsPred '[] CounterCommand) '[] CounterState CounterCommand CounterEvent--type SnapshotCounterRegs = '[ '("lastAmount", Int)]--type UninitializedSnapshotRegs = '[ '("initialized", Int), '("neverWritten", Int)]--type SnapshotCounterEventStream = EventStream (HsPred SnapshotCounterRegs CounterCommand) SnapshotCounterRegs CounterState CounterCommand CounterEvent--type PartialSnapshotEventStream = EventStream (HsPred SnapshotCounterRegs CounterCommand) SnapshotCounterRegs PartialSnapshotState CounterCommand CounterEvent--type ValidatedSnapshotCounterEventStream = ValidatedEventStream (HsPred SnapshotCounterRegs CounterCommand) SnapshotCounterRegs CounterState CounterCommand CounterEvent--type UninitializedSnapshotEventStream = EventStream (HsPred UninitializedSnapshotRegs CounterCommand) UninitializedSnapshotRegs CounterState CounterCommand CounterEvent--data CounterCommand-    = Add !Int-    deriving stock (Generic, Eq, Show)--data SkipCommand-    = SAdd !Int-    | SSkip-    deriving stock (Generic, Eq, Show)--data CounterEvent-    = CounterAdded !Int-    | CounterAudited !Int-    deriving stock (Generic, Eq, Show)--data CounterState-    = Counting-    deriving stock (Generic, Eq, Show, Enum, Bounded, Ord)-    deriving anyclass (FromJSON, ToJSON)--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--skipEventStream :: ValidatedSkipEventStream-skipEventStream = mkEventStreamOrThrow "skip-command" skipEventStreamDef--skipEventStreamDef :: SkipEventStream-skipEventStreamDef =-    EventStream-        { transducer = skipTransducer-        , initialState = Counting-        , initialRegisters = RNil-        , eventCodec = counterCodec-        , resolveStreamName = Stream.streamName-        , snapshotPolicy = Never-        , stateCodec = Nothing-        }--skipTransducer :: SymTransducer (HsPred '[] SkipCommand) '[] CounterState SkipCommand CounterEvent-skipTransducer =-    SymTransducer-        { edgesOut = \case-            Counting ->-                [ Edge-                    { guard = matchInCtor sAddCtor-                    , update = UKeep-                    , output = [pack sAddCtor counterAddedCtor (inpCtor sAddCtor #amount *: oNil)]-                    , target = Counting-                    , 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 =-    InCtor-        { icName = "SAdd"-        , icMatch = \case-            SAdd amount -> Just (RCons Proxy amount RNil)-            SSkip -> Nothing-        , icBuild = \case-            RCons _ amount RNil -> SAdd amount-        }--sSkipCtor :: InCtor SkipCommand '[]-sSkipCtor =-    InCtor-        { icName = "SSkip"-        , icMatch = \case-            SAdd{} -> Nothing-            SSkip -> Just RNil-        , icBuild = \case-            RNil -> SSkip-        }--addCtor :: InCtor CounterCommand AddFields-addCtor =-    InCtor-        { icName = "Add"-        , icMatch = \case-            Add amount -> Just (RCons Proxy amount RNil)-        , icBuild = \case-            RCons _ amount RNil -> Add amount-        }--counterAddedCtor :: WireCtor CounterEvent (Int, ())-counterAddedCtor =-    WireCtor-        { wcName = "CounterAdded"-        , wcMatch = \case-            CounterAdded amount -> Just (amount, ())-            CounterAudited{} -> Nothing-        , wcBuild = \case-            (amount, ()) -> CounterAdded amount-        }--counterAuditedCtor :: WireCtor CounterEvent (Int, ())-counterAuditedCtor =-    WireCtor-        { wcName = "CounterAudited"-        , wcMatch = \case-            CounterAudited amount -> Just (amount, ())-            CounterAdded{} -> Nothing-        , wcBuild = \case-            (amount, ()) -> CounterAudited amount-        }--counterCodec :: Codec CounterEvent-counterCodec =-    Codec-        { eventTypes = EventType "CounterAdded" :| [EventType "CounterAudited"]-        , eventType = \case-            CounterAdded{} -> EventType "CounterAdded"-            CounterAudited{} -> EventType "CounterAudited"-        , schemaVersion = 1-        , encode = \case-            CounterAdded amount -> object ["amount" Aeson..= amount]-            CounterAudited amount -> object ["amount" Aeson..= amount, "audited" Aeson..= True]-        , decode = parseCounterEvent-        , upcasters = []-        }--parseCounterEvent :: EventType -> Value -> Either Text CounterEvent-parseCounterEvent (EventType tag) value =-    case parseEither parser value of-        Right event -> Right event-        Left message -> Left (fromStringLiteral message)-  where-    parser = withObject "CounterEvent" $ \objectValue -> do-        amount <- objectValue .: "amount"-        case tag of-            "CounterAdded" -> pure (CounterAdded amount)-            "CounterAudited" -> pure (CounterAudited amount)-            _ -> fail "unknown counter event type"---- * 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 =-    InCtor-        { icName = "ConfirmDivert"-        , icMatch = \case-            ConfirmDivert acuityBlack -> Just (RCons Proxy acuityBlack RNil)-        , icBuild = \case-            RCons _ acuityBlack RNil -> ConfirmDivert acuityBlack-        }--divertConfirmedCtor :: WireCtor DivertEvent (Bool, ())-divertConfirmedCtor =-    WireCtor-        { wcName = "DivertConfirmed"-        , wcMatch = \case-            DivertConfirmed acuityBlack -> Just (acuityBlack, ())-        , wcBuild = \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-            ]-        )--counterProcessManager ::-    ProcessManager-        CounterEvent-        (HsPred '[] CounterCommand)-        '[]-        CounterState-        CounterCommand-        CounterEvent-        (HsPred '[] CounterCommand)-        '[]-        CounterState-        CounterCommand-        CounterEvent-counterProcessManager =-    ProcessManager-        { name = "counter-pm"-        , correlate = \_ -> "order-1"-        , eventStream = counterEventStream-        , streamFor = \correlationId -> stream ("pm:counter-" <> correlationId)-        , targetEventStream = counterEventStream-        , targetProjections = const []-        , handle = \case-            CounterAdded amount ->-                ProcessManagerAction-                    { command = Add amount-                    , commands =-                        [ PMCommand-                            { target = stream "counter-target-order-1"-                            , command = Add amount-                            }-                        ]-                    , timers = [counterTimerRequest]-                    }-            CounterAudited amount ->-                ProcessManagerAction-                    { command = Add amount-                    , commands = []-                    , timers = []-                    }-        }--timerOnlyProcessManager ::-    ProcessManager-        CounterEvent-        (HsPred '[] CounterCommand)-        '[]-        CounterState-        CounterCommand-        CounterEvent-        (HsPred '[] CounterCommand)-        '[]-        CounterState-        CounterCommand-        CounterEvent-timerOnlyProcessManager =-    ProcessManager-        { name = "timer-only-pm"-        , correlate = \_ -> "order-1"-        , eventStream = noOpCounterEventStream-        , streamFor = \correlationId -> stream ("pm:timer-only-" <> correlationId)-        , targetEventStream = counterEventStream-        , targetProjections = const []-        , handle = \case-            CounterAdded amount ->-                ProcessManagerAction-                    { command = Add amount-                    , commands = []-                    , timers =-                        [ counterTimerRequest-                            & #processManagerName-                            .~ "timer-only-pm"-                        ]-                    }-            CounterAudited amount ->-                ProcessManagerAction-                    { command = Add amount-                    , commands = []-                    , timers = []-                    }-        }---- A process manager whose OWN state stream snapshots under Every 2.--- This is the first PM fixture to exercise a state-stream snapshot: the only--- difference from counterProcessManager is that its eventStream carries a--- snapshotPolicy + stateCodec (it reuses snapshotCounterEventStream), so--- runProcessManagerOnce's manager-state append (which goes through--- runCommandWithSql) writes and reuses snapshots. The manager registers are--- SnapshotCounterRegs because the eventStream is a SnapshotCounterEventStream;--- the target side stays '[]/counterEventStream exactly as counterProcessManager.-pmSnapshotCounterEventStreamDef :: SnapshotCounterEventStream-pmSnapshotCounterEventStreamDef = snapshotCounterEventStreamDef--pmSnapshotCounterEventStream :: ValidatedSnapshotCounterEventStream-pmSnapshotCounterEventStream = mkEventStreamOrThrow "pm-snapshot-counter" pmSnapshotCounterEventStreamDef--pmSnapshotProcessManager ::-    ProcessManager-        CounterEvent-        (HsPred SnapshotCounterRegs CounterCommand)-        SnapshotCounterRegs-        CounterState-        CounterCommand-        CounterEvent-        (HsPred '[] CounterCommand)-        '[]-        CounterState-        CounterCommand-        CounterEvent-pmSnapshotProcessManager =-    ProcessManager-        { name = "counter-snap-pm"-        , correlate = \_ -> "order-1"-        , eventStream = pmSnapshotCounterEventStream-        , streamFor = \correlationId -> stream ("pm:counter-snap-" <> correlationId)-        , targetEventStream = counterEventStream-        , targetProjections = const []-        , handle = \case-            CounterAdded amount ->-                ProcessManagerAction-                    { command = Add amount-                    , commands = [] -- keep the test focused on the manager state stream-                    , timers = []-                    }-            CounterAudited amount ->-                ProcessManagerAction-                    { command = Add amount-                    , commands = []-                    , timers = []-                    }-        }--workflowProcessManager ::-    Text ->-    Text ->-    Text ->-    ProcessManager-        CounterEvent-        (HsPred '[] CounterCommand)-        '[]-        CounterState-        CounterCommand-        CounterEvent-        (HsPred '[] CounterCommand)-        '[]-        CounterState-        CounterCommand-        CounterEvent-workflowProcessManager managerName managerCategory targetStreamName =-    counterProcessManager-        { name = managerName-        , streamFor = \correlationId -> stream (managerCategory <> "-" <> correlationId)-        , handle = \case-            CounterAdded amount ->-                ProcessManagerAction-                    { command = Add amount-                    , commands =-                        [ PMCommand-                            { target = stream targetStreamName-                            , command = Add amount-                            }-                        ]-                    , timers = []-                    }-            CounterAudited amount ->-                ProcessManagerAction-                    { command = Add amount-                    , commands = []-                    , timers = []-                    }-        }--assertWorkflowProcessManagerAppended ::-    Either-        Store.StoreError-        ( Either-            CommandError-            (ProcessManagerResult CounterEventStream CounterEventStream)-        ) ->-    Expectation-assertWorkflowProcessManagerAppended = \case-    Right (Right pmResult) -> do-        pmResult ^. #managerResult `shouldSatisfy` \case-            PMStateAppended{} -> True-            _ -> False-        pmResult ^. #commandResults `shouldSatisfy` \case-            [PMCommandAppended{}] -> True-            _ -> False-    other -> expectationFailure ("expected workflow process-manager success, got " <> show other)--counterTimerRequest :: TimerRequest-counterTimerRequest =-    TimerRequest-        { timerId = TimerId sampleUuid-        , processManagerName = "counter-pm"-        , correlationId = "order-1"-        , fireAt = dueTimerTime-        , payload = object ["kind" Aeson..= ("counter-timeout" :: Text)]-        }--dueTimerTime :: UTCTime-dueTimerTime = UTCTime (ModifiedJulianDay 1) (secondsToDiffTime 0)--timerStatusAndErrorStmt :: Statement UUID (Maybe (Text, Maybe Text))-timerStatusAndErrorStmt =-    preparable-        """-        SELECT status, last_error-        FROM keiro.keiro_timers-        WHERE timer_id = $1-        """-        (E.param (E.nonNullable E.uuid))-        (D.rowMaybe ((,) <$> D.column (D.nonNullable D.text) <*> D.column (D.nullable D.text)))---- | Read a timer's status and JSON payload by id (for the workflow-sleep tests).-sleepTimerStatusStmt :: Statement UUID (Maybe (Text, Value))-sleepTimerStatusStmt =-    preparable-        """-        SELECT status, payload-        FROM keiro.keiro_timers-        WHERE timer_id = $1-        """-        (E.param (E.nonNullable E.uuid))-        (D.rowMaybe ((,) <$> D.column (D.nonNullable D.text) <*> D.column (D.nonNullable D.jsonb)))---- | Read a timer's fire time by id (for workflow-sleep re-arm tests).-sleepTimerFireAtStmt :: Statement UUID (Maybe UTCTime)-sleepTimerFireAtStmt =-    preparable-        """-        SELECT fire_at-        FROM keiro.keiro_timers-        WHERE timer_id = $1-        """-        (E.param (E.nonNullable E.uuid))-        (D.rowMaybe (D.column (D.nonNullable D.timestamptz)))--recordedFrom :: EventData -> RecordedEvent-recordedFrom event =-    RecordedEvent-        { eventId = EventId sampleUuid-        , eventType = event ^. #eventType-        , streamVersion = StreamVersion 1-        , globalPosition = GlobalPosition 1-        , originalStreamId = StreamId 1-        , originalVersion = StreamVersion 1-        , payload = event ^. #payload-        , metadata = event ^. #metadata-        , causationId = Nothing-        , correlationId = Nothing-        , createdAt = UTCTime (ModifiedJulianDay 0) (secondsToDiffTime 0)-        }--recordedFromEventId :: EventId -> CounterEvent -> RecordedEvent-recordedFromEventId eventId event =-    case encodeForAppend counterCodec event of-        Right encoded -> recordedFrom encoded & #eventId .~ eventId-        Left err -> error ("test fixture failed to encode counter event: " <> show err)--appendCounterEventWithId :: Store.KirokuStore -> StreamName -> EventId -> CounterEvent -> IO ()-appendCounterEventWithId storeHandle streamName eventId event = do-    encoded <- shouldBeRight (encodeForAppend counterCodec event)-    outcome <--        Store.runStoreIO storeHandle $-            Store.appendToStream streamName NoStream [encoded & #eventId ?~ eventId]-    case outcome of-        Right _ -> pure ()-        Left err -> expectationFailure ("failed to insert concurrent duplicate event: " <> show err)--appendCounterEvents :: Store.KirokuStore -> StreamName -> [CounterEvent] -> IO ()-appendCounterEvents storeHandle destinationStreamName events = do-    encoded <- traverse (shouldBeRight . encodeForAppend counterCodec) events-    outcome <--        Store.runStoreIO storeHandle $-            Store.appendToStream destinationStreamName NoStream encoded-    case outcome of-        Right _ -> pure ()-        Left err -> expectationFailure ("failed to insert counter events: " <> show err)---- Insert a real source event and drive Kiroku's acknowledgement bridge to park--- it in kiroku.dead_letters. A second event lets the test observe that the--- checkpoint advanced after the dead letter before stopping the subscription.-deadLetterCounterSource :: Store.KirokuStore -> SubscriptionName -> CounterEvent -> IO RecordedEvent-deadLetterCounterSource storeHandle subName sourceEvent = do-    appendCounterEvents-        storeHandle-        (StreamName "counter-replay-source")-        [sourceEvent, CounterAdded 0]-    let subConfig =-            ( KirokuSub.defaultSubscriptionConfig-                subName-                AllStreams-                (\_ -> pure KirokuSub.Continue)-            )-                { KirokuSub.retryPolicy = KirokuSub.RetryPolicy 1-                }-        pull label source = do-            result <- timeout 5_000_000 (Streamly.uncons source)-            case result of-                Just (Just itemAndRest) -> pure itemAndRest-                Just Nothing -> fail (label <> ": subscription ended early")-                Nothing -> fail (label <> ": timed out waiting for delivery")-    (stream0, cancelStream) <- subscriptionAckStream storeHandle subConfig 4-    ( do-            (first, stream1) <- pull "source delivery" stream0-            atomically $-                putTMVar-                    (ackReply first)-                    (KirokuSub.Retry (KirokuSub.RetryDelay 0))-            (next, stream2) <- pull "event after source dead letter" stream1-            ackEvent next ^. #eventId `shouldNotBe` ackEvent first ^. #eventId-            atomically (putTMVar (ackReply next) KirokuSub.Stop)-            ended <- timeout 5_000_000 (Streamly.uncons stream2)-            case ended of-                Just Nothing -> pure ()-                Just (Just _) -> expectationFailure "replay fixture delivered after Stop"-                Nothing -> expectationFailure "replay fixture did not stop"-            pure (ackEvent first)-        )-        `finally` cancelStream--classifyProcessManagerReplay :: ProcessManagerResult managerTarget commandTarget -> ReplayResult-classifyProcessManagerReplay result =-    case result ^. #managerResult of-        PMStateDuplicate{}-            | Prelude.all commandIsDuplicate (result ^. #commandResults) -> ReplayedDuplicate-        _ -> ReplayedFresh-  where-    commandIsDuplicate = \case-        PMCommandDuplicate{} -> True-        _ -> False--processManagerReplayCounts :: Store.KirokuStore -> IO (Int, Int)-processManagerReplayCounts storeHandle = do-    Right managerEvents <--        Store.runStoreIO storeHandle $-            Store.readStreamForward (StreamName "pm:counter-order-1") (StreamVersion 0) 10-    Right targetEvents <--        Store.runStoreIO storeHandle $-            Store.readStreamForward (StreamName "counter-target-order-1") (StreamVersion 0) 10-    pure (Vector.length managerEvents, Vector.length targetEvents)--sampleUuid :: UUID-sampleUuid =-    case fromString "018f0f18-17aa-7000-8000-000000000001" of-        Just uuid -> uuid-        Nothing -> error "invalid test UUID"--sampleUuid2 :: UUID-sampleUuid2 =-    case fromString "018f0f18-17aa-7000-8000-000000000002" of-        Just uuid -> uuid-        Nothing -> error "invalid test UUID"--sampleUuid3 :: UUID-sampleUuid3 =-    case fromString "018f0f18-17aa-7000-8000-000000000003" of-        Just uuid -> uuid-        Nothing -> error "invalid test UUID"--shouldBeRight :: (HasCallStack, Show e) => Either e a -> IO a-shouldBeRight = \case-    Right value -> pure value-    Left err -> expectationFailure ("expected Right, got Left " <> show err) *> error "unreachable"--shouldBeRight_ :: (HasCallStack, Show e) => Either e a -> Expectation-shouldBeRight_ = \case-    Right _ -> pure ()-    Left err -> expectationFailure ("expected Right, got Left " <> show err)--shouldBeLeft :: (HasCallStack, Eq e, Show e) => Either e a -> e -> Expectation-shouldBeLeft actual expected =-    case actual of-        Left err -> err `shouldBe` expected-        Right _ -> expectationFailure ("expected Left " <> show expected <> ", got Right")--fromStringLiteral :: String -> Text-fromStringLiteral = Text.pack--snapshotVersionForStreamStmt :: Statement Text (Maybe StreamVersion)-snapshotVersionForStreamStmt =-    preparable-        """-        SELECT ks.stream_version-        FROM keiro.keiro_snapshots ks-        JOIN streams s ON s.stream_id = ks.stream_id-        WHERE s.stream_name = $1-        """-        (E.param (E.nonNullable E.text))-        (D.rowMaybe (StreamVersion <$> D.column (D.nonNullable D.int8)))--snapshotStateShapeForStreamStmt :: Statement Text (Maybe Text)-snapshotStateShapeForStreamStmt =-    preparable-        """-        SELECT ks.state_shape_hash-        FROM keiro.keiro_snapshots ks-        JOIN streams s ON s.stream_id = ks.stream_id-        WHERE s.stream_name = $1-        """-        (E.param (E.nonNullable E.text))-        (D.rowMaybe (D.column (D.nonNullable D.text)))--corruptSnapshotStateStmt :: Statement (Text, Value) ()-corruptSnapshotStateStmt =-    preparable-        """-        UPDATE keiro.keiro_snapshots ks-        SET state = $2-        FROM streams s-        WHERE s.stream_id = ks.stream_id-          AND s.stream_name = $1-        """-        ( contrazip2-            (E.param (E.nonNullable E.text))-            (E.param (E.nonNullable E.jsonb))-        )-        D.noResult--corruptSnapshotShapeStmt :: Statement (Text, Text) ()-corruptSnapshotShapeStmt =-    preparable-        """-        UPDATE keiro.keiro_snapshots ks-        SET regfile_shape_hash = $2-        FROM streams s-        WHERE s.stream_id = ks.stream_id-          AND s.stream_name = $1-        """-        ( contrazip2-            (E.param (E.nonNullable E.text))-            (E.param (E.nonNullable E.text))-        )-        D.noResult--counterReadModel :: ReadModel Text Int-counterReadModel =-    ReadModel-        { name = "counter-read-model"-        , tableName = "counter_read_model"-        , schema = "kiroku"-        , subscriptionName = "counter-read-model-sub"-        , version = 1-        , shapeHash = "counter-read-model-v1"-        , defaultConsistency = Eventual-        , strongScope = EntireLog-        , query = \modelId -> Tx.statement modelId selectCounterReadModelStmt-        }--counterCategoryReadModel :: ReadModel Text Int-counterCategoryReadModel =-    counterReadModel & #strongScope .~ CategoryHead "counter"--registerReadModelDefinition :: (Store :> es) => ReadModel q r -> Eff es ()-registerReadModelDefinition readModel =-    void $-        registerReadModel-            (readModel ^. #name)-            (readModel ^. #version)-            (readModel ^. #shapeHash)--initializeRegisteredReadModel ::-    (Store :> es) =>-    ReadModel q r ->-    Tx.Transaction () ->-    Eff es ()-initializeRegisteredReadModel readModel initializeTable = do-    Store.runTransaction initializeTable-    registerReadModelDefinition readModel--counterInlineProjection :: InlineProjection CounterEvent-counterInlineProjection =-    InlineProjection-        { name = "counter-inline-projection"-        , apply = \event recorded ->-            case event of-                CounterAdded amount ->-                    Tx.statement-                        ( "inline"-                        , Prelude.fromIntegral amount-                        , globalPositionToInt (recorded ^. #globalPosition)-                        , Just (eventIdToUuid (recorded ^. #eventId))-                        , metadataActor recorded-                        )-                        upsertCounterReadModelStmt-                CounterAudited{} -> pure ()-        }--counterAsyncProjection :: AsyncProjection-counterAsyncProjection =-    AsyncProjection-        { name = "counter-async-projection"-        , readModelName = "counter-read-model"-        , subscriptionName = "counter-read-model-sub"-        , applyRecorded = \recorded ->-            case decodeRecorded counterCodec recorded of-                Right (CounterAdded amount) ->-                    Tx.statement-                        ( "async-idempotent"-                        , Prelude.fromIntegral amount-                        , globalPositionToInt (recorded ^. #globalPosition)-                        , Just (eventIdToUuid (recorded ^. #eventId))-                        , Nothing-                        )-                        upsertCounterReadModelStmt-                Right CounterAudited{} -> pure ()-                Left _ -> pure ()-        , idempotencyKey = \recorded -> recorded ^. #eventId-        }--fastWaitOptions :: PositionWaitOptions-fastWaitOptions =-    PositionWaitOptions-        { target = Nothing-        , timeoutMicros = 50000-        , pollMicros = 5000-        }--initializeCounterReadModelTable :: Tx.Transaction ()-initializeCounterReadModelTable =-    Tx.sql-        """-        CREATE TABLE IF NOT EXISTS counter_read_model (-          model_id TEXT PRIMARY KEY,-          amount BIGINT NOT NULL,-          last_seen BIGINT NOT NULL,-          source_event_id UUID UNIQUE,-          actor TEXT-        )-        """---- A read model whose data table lives in an application-configured schema--- (@app_reads@), demonstrating EP-4's configurable projection schema. Its SQL is--- fully qualified via 'placedTable'; Keiro's own metadata stays in @keiro@.-placedTable :: Text-placedTable = qualifyTable "app_reads" "placed_counter"--placedReadModel :: ReadModel Text Int-placedReadModel =-    ReadModel-        { name = "placed-counter-read-model"-        , tableName = "placed_counter"-        , schema = "app_reads"-        , subscriptionName = "placed-counter-sub"-        , version = 1-        , shapeHash = "placed-counter-v1"-        , defaultConsistency = Eventual-        , strongScope = EntireLog-        , query = \modelId -> Tx.statement modelId selectPlacedStmt-        }--placedInlineProjection :: InlineProjection CounterEvent-placedInlineProjection =-    InlineProjection-        { name = "placed-inline-projection"-        , apply = \event recorded ->-            case event of-                CounterAdded amount ->-                    Tx.statement-                        ( "placed"-                        , Prelude.fromIntegral amount-                        , globalPositionToInt (recorded ^. #globalPosition)-                        )-                        upsertPlacedStmt-                CounterAudited{} -> pure ()-        }--initializePlacedTable :: Tx.Transaction ()-initializePlacedTable =-    Tx.sql $-        TE.encodeUtf8 $-            "CREATE TABLE IF NOT EXISTS "-                <> placedTable-                <> " (\n"-                <> "  model_id TEXT PRIMARY KEY,\n"-                <> "  amount BIGINT NOT NULL,\n"-                <> "  last_seen BIGINT NOT NULL\n"-                <> ")"--upsertPlacedStmt :: Statement (Text, Int64, Int64) ()-upsertPlacedStmt =-    preparable-        ( "INSERT INTO "-            <> placedTable-            <> " (model_id, amount, last_seen)\n"-            <> "VALUES ($1, $2, $3)\n"-            <> "ON CONFLICT (model_id) DO UPDATE\n"-            <> "  SET amount = EXCLUDED.amount, last_seen = EXCLUDED.last_seen"-        )-        ( contrazip3-            (E.param (E.nonNullable E.text))-            (E.param (E.nonNullable E.int8))-            (E.param (E.nonNullable E.int8))-        )-        D.noResult--selectPlacedStmt :: Statement Text Int-selectPlacedStmt =-    preparable-        ("SELECT COALESCE((SELECT amount FROM " <> placedTable <> " WHERE model_id = $1), 0)")-        (E.param (E.nonNullable E.text))-        (D.singleRow (Prelude.fromIntegral <$> D.column (D.nonNullable D.int8)))---- Count matching base tables in a given schema; proves table placement.-pgTableCountStmt :: Statement (Text, Text) Int-pgTableCountStmt =-    preparable-        "SELECT count(*)::int FROM pg_tables WHERE schemaname = $1 AND tablename = $2"-        ( contrazip2-            (E.param (E.nonNullable E.text))-            (E.param (E.nonNullable E.text))-        )-        (D.singleRow (Prelude.fromIntegral <$> D.column (D.nonNullable D.int4)))--initializeProjectionDedupCounterTable :: Tx.Transaction ()-initializeProjectionDedupCounterTable =-    Tx.sql-        """-        CREATE TABLE IF NOT EXISTS projection_dedup_counter (-          id BOOLEAN PRIMARY KEY DEFAULT TRUE,-          amount BIGINT NOT NULL-        );--        INSERT INTO projection_dedup_counter (id, amount)-        VALUES (TRUE, 0)-        ON CONFLICT (id) DO NOTHING;-        """--upsertCounterReadModelStmt :: Statement (Text, Int64, Int64, Maybe UUID, Maybe Text) ()-upsertCounterReadModelStmt =-    preparable-        """-        INSERT INTO counter_read_model (model_id, amount, last_seen, source_event_id, actor)-        VALUES ($1, $2, $3, $4, $5)-        ON CONFLICT (source_event_id) DO NOTHING-        """-        ( contrazip5-            (E.param (E.nonNullable E.text))-            (E.param (E.nonNullable E.int8))-            (E.param (E.nonNullable E.int8))-            (E.param (E.nullable E.uuid))-            (E.param (E.nullable E.text))-        )-        D.noResult--incrementProjectionDedupCounterStmt :: Statement () ()-incrementProjectionDedupCounterStmt =-    preparable-        """-        UPDATE projection_dedup_counter-        SET amount = amount + 1-        WHERE id = TRUE-        """-        E.noParams-        D.noResult--selectProjectionDedupCounterStmt :: Statement () Int-selectProjectionDedupCounterStmt =-    preparable-        """-        SELECT amount-        FROM projection_dedup_counter-        WHERE id = TRUE-        """-        E.noParams-        (D.singleRow (Prelude.fromIntegral <$> D.column (D.nonNullable D.int8)))--projectionDedupCountStmt :: Statement Text Int64-projectionDedupCountStmt =-    preparable-        """-        SELECT count(*)-        FROM keiro.keiro_projection_dedup-        WHERE projection_name = $1-        """-        (E.param (E.nonNullable E.text))-        (D.singleRow (D.column (D.nonNullable D.int8)))--selectCounterMetaStmt :: Statement Text (Int64, Maybe Text, Maybe UUID)-selectCounterMetaStmt =-    preparable-        """-        SELECT amount, actor, source_event_id-        FROM counter_read_model-        WHERE model_id = $1-        """-        (E.param (E.nonNullable E.text))-        ( D.singleRow-            ( (,,)-                <$> D.column (D.nonNullable D.int8)-                <*> D.column (D.nullable D.text)-                <*> D.column (D.nullable D.uuid)-            )-        )--selectCounterReadModelStmt :: Statement Text Int-selectCounterReadModelStmt =-    preparable-        """-        SELECT COALESCE((SELECT amount FROM counter_read_model WHERE model_id = $1), 0)-        """-        (E.param (E.nonNullable E.text))-        (D.singleRow (Prelude.fromIntegral <$> D.column (D.nonNullable D.int8)))--upsertSubscriptionCursorStmt :: Statement (Text, Int64) ()-upsertSubscriptionCursorStmt =-    preparable-        """-        INSERT INTO subscriptions (subscription_name, stream_name, last_seen)-        VALUES ($1, '$all', $2)-        ON CONFLICT (subscription_name, consumer_group_member) DO UPDATE-          SET last_seen = EXCLUDED.last_seen,-              updated_at = now()-        """-        ( contrazip2-            (E.param (E.nonNullable E.text))-            (E.param (E.nonNullable E.int8))-        )-        D.noResult--upsertSubscriptionCursorMemberStmt :: Statement (Text, Int32, Int64) ()-upsertSubscriptionCursorMemberStmt =-    preparable-        """-        INSERT INTO subscriptions (subscription_name, stream_name, consumer_group_member, consumer_group_size, last_seen)-        VALUES ($1, '$all', $2, 2, $3)-        ON CONFLICT (subscription_name, consumer_group_member) DO UPDATE-          SET last_seen = EXCLUDED.last_seen,-              updated_at = now()-        """-        ( contrazip3-            (E.param (E.nonNullable E.text))-            (E.param (E.nonNullable E.int4))-            (E.param (E.nonNullable E.int8))-        )-        D.noResult--updateReadModelVersionStmt :: Statement (Text, Int64) ()-updateReadModelVersionStmt =-    preparable-        """-        UPDATE keiro.keiro_read_models-        SET version = $2-        WHERE name = $1-        """-        ( contrazip2-            (E.param (E.nonNullable E.text))-            (E.param (E.nonNullable E.int8))-        )-        D.noResult--updateReadModelStatusStmt :: Statement (Text, Text) ()-updateReadModelStatusStmt =-    preparable-        """-        UPDATE keiro.keiro_read_models-        SET status = $2-        WHERE name = $1-        """-        ( contrazip2-            (E.param (E.nonNullable E.text))-            (E.param (E.nonNullable E.text))-        )-        D.noResult--readModelXminStmt :: Statement Text Text-readModelXminStmt =-    preparable-        """-        SELECT xmin::text-        FROM keiro.keiro_read_models-        WHERE name = $1-        """-        (E.param (E.nonNullable E.text))-        (D.singleRow (D.column (D.nonNullable D.text)))--globalPositionToInt :: GlobalPosition -> Int64-globalPositionToInt (GlobalPosition value) = value--eventIdToUuid :: EventId -> UUID-eventIdToUuid (EventId value) = value--metadataActor :: RecordedEvent -> Maybe Text-metadataActor recorded = do-    Aeson.Object o <- recorded ^. #metadata-    Aeson.String s <- KeyMap.lookup "actor" o-    pure s---- Router test fixtures: an effectful, data-dependent fan-out whose target set--- is stored in a read-model table (router_targets) rather than computed purely.--newtype RouteGroup = RouteGroup Text-    deriving stock (Generic, Eq, Show)--{- | Maps a routing group to the list of target counter stream identifiers seeded-for it. The query is genuinely effectful: 'demoRouter' calls it via 'runQuery'.--}-routerTargetsReadModel :: ReadModel Text [Text]-routerTargetsReadModel =-    ReadModel-        { name = "router-targets-read-model"-        , tableName = "router_targets"-        , schema = "kiroku"-        , subscriptionName = "router-targets-sub"-        , version = 1-        , shapeHash = "router-targets-v1"-        , defaultConsistency = Eventual-        , strongScope = EntireLog-        , query = \groupId -> Tx.statement groupId selectRouterTargetsStmt-        }--demoRouter ::-    (IOE :> es, Store :> es) =>-    Router-        RouteGroup-        (HsPred '[] CounterCommand)-        '[]-        CounterState-        CounterCommand-        CounterEvent-        es-demoRouter =-    Router-        { name = "demo-router"-        , key = \(RouteGroup g) -> g-        , resolve = \(RouteGroup g) -> do-            result <- runQuery Nothing routerTargetsReadModel g-            pure $ case result of-                Right targetIds ->-                    [ PMCommand{target = stream targetId, command = Add 1}-                    | targetId <- targetIds-                    ]-                Left _ -> []-        , targetEventStream = counterEventStream-        , targetProjections = const []-        }--unstableRouter ::-    (IOE :> es) =>-    IORef Int ->-    (Int -> [Text]) ->-    Router-        RouteGroup-        (HsPred '[] CounterCommand)-        '[]-        CounterState-        CounterCommand-        CounterEvent-        es-unstableRouter attemptsRef targetsFor =-    Router-        { name = "unstable-router"-        , key = \(RouteGroup g) -> g-        , resolve = \_ -> do-            attempt <- liftIO (atomicModifyIORef' attemptsRef (\n -> (n + 1, n)))-            pure-                [ PMCommand{target = stream targetId, command = Add 1}-                | targetId <- targetsFor attempt-                ]-        , targetEventStream = counterEventStream-        , targetProjections = const []-        }--isAppended :: PMCommandResult target -> Bool-isAppended = \case-    PMCommandAppended{} -> True-    _ -> False--isDuplicate :: PMCommandResult target -> Bool-isDuplicate = \case-    PMCommandDuplicate{} -> True-    _ -> False--initializeRouterTargetsTable :: Tx.Transaction ()-initializeRouterTargetsTable =-    Tx.sql-        """-        CREATE TABLE IF NOT EXISTS router_targets (-          group_id TEXT NOT NULL,-          target_id TEXT NOT NULL-        )-        """--insertRouterTargetStmt :: Statement (Text, Text) ()-insertRouterTargetStmt =-    preparable-        """-        INSERT INTO router_targets (group_id, target_id)-        VALUES ($1, $2)-        """-        ( contrazip2-            (E.param (E.nonNullable E.text))-            (E.param (E.nonNullable E.text))-        )-        D.noResult--selectRouterTargetsStmt :: Statement Text [Text]-selectRouterTargetsStmt =-    preparable-        """-        SELECT target_id-        FROM router_targets-        WHERE group_id = $1-        ORDER BY target_id-        """-        (E.param (E.nonNullable E.text))-        (D.rowList (D.column (D.nonNullable D.text)))---- Router worker fixtures: an in-memory Shibuya adapter that records every--- finalized AckDecision, plus a router whose dispatch always fails.--inMemoryAdapter ::-    (IOE :> es) =>-    IORef [AckDecision] ->-    [msg] ->-    Adapter es msg-inMemoryAdapter decisionsRef messages =-    Adapter-        { adapterName = "router-test-adapter"-        , source = Streamly.fromList (fmap ingest messages)-        , shutdown = pure ()-        }-  where-    ingest message =-        Ingested-            { envelope = routerTestEnvelope message-            , ack = AckHandle (\decision -> liftIO (modifyIORef' decisionsRef (<> [decision])))-            , lease = Nothing-            }--routerTestEnvelope :: msg -> Envelope msg-routerTestEnvelope message =-    Envelope-        { messageId = "router-test-message"-        , cursor = Nothing-        , partition = Nothing-        , enqueuedAt = Nothing-        , traceContext = Nothing-        , headers = Nothing-        , attempt = Nothing-        , attributes = mempty-        , payload = message-        }--{- | A target aggregate with no outgoing edges: every command is rejected-(CommandRejected), so a dispatch through it surfaces as PMCommandFailed,-driving the worker's AckHalt branch.--}-rejectingEventStreamDef :: CounterEventStream-rejectingEventStreamDef =-    counterEventStreamDef & #transducer .~ rejectingTransducer--rejectingEventStream :: ValidatedCounterEventStream-rejectingEventStream = mkEventStreamOrThrow "rejecting-counter" rejectingEventStreamDef--{- | Accept every Add command except amount 9, which exercises a worker that-dead-letters one rejected dispatch and then successfully processes the next.--}-rejectNineEventStream :: ValidatedCounterEventStream-rejectNineEventStream = mkEventStreamOrThrow "reject-nine-counter" rejectNineEventStreamDef--rejectNineEventStreamDef :: CounterEventStream-rejectNineEventStreamDef =-    counterEventStreamDef & #transducer .~ rejectNineTransducer--rejectNineTransducer :: SymTransducer (HsPred '[] CounterCommand) '[] CounterState CounterCommand CounterEvent-rejectNineTransducer =-    SymTransducer-        { edgesOut = \case-            Counting ->-                [ Edge-                    { guard =-                        PAnd-                            (matchInCtor addCtor)-                            (PNot (inpCtor addCtor #amount .== Keiki.lit 9))-                    , update = UKeep-                    , output = [pack addCtor counterAddedCtor (inpCtor addCtor #amount *: oNil)]-                    , target = Counting-                    , mode = Keiki.Live-                    }-                ]-        , initial = Counting-        , initialRegs = RNil-        , isFinal = \_ -> False-        }--rejectingTransducer :: SymTransducer (HsPred '[] CounterCommand) '[] CounterState CounterCommand CounterEvent-rejectingTransducer =-    SymTransducer-        { edgesOut = \case-            Counting -> []-        , initial = Counting-        , initialRegs = RNil-        , isFinal = \_ -> False-        }--failingRouter ::-    Router-        RouteGroup-        (HsPred '[] CounterCommand)-        '[]-        CounterState-        CounterCommand-        CounterEvent-        es-failingRouter =-    Router-        { name = "failing-router"-        , key = \(RouteGroup g) -> g-        , resolve = \_ -> pure [PMCommand{target = stream "failing-target", command = Add 1}]-        , targetEventStream = rejectingEventStream-        , targetProjections = const []-        }---- Flatten exported counter/gauge points to (instrument name, value).-flattenScalarPoints :: [ResourceMetricsExport] -> [(Text, NumberValue)]-flattenScalarPoints rmes =-    [ (name, val)-    | rme <- rmes-    , scope <- Vector.toList (resourceMetricsScopes rme)-    , export <- Vector.toList (scopeMetricsExports scope)-    , (name, val) <- pointsOf export-    ]-  where-    pointsOf (MetricExportSum n _ _ _ _ _ _ pts) =-        [(n, sumDataPointValue p) | p <- Vector.toList pts]-    pointsOf (MetricExportGauge n _ _ _ _ pts) =-        [(n, gaugeDataPointValue p) | p <- Vector.toList pts]-    pointsOf _ = []---- Flatten exported histogram points to (instrument name, count, sum).-flattenHistogramPoints :: [ResourceMetricsExport] -> [(Text, Word64, Double)]-flattenHistogramPoints rmes =-    [ (n, histogramDataPointCount p, histogramDataPointSum p)-    | rme <- rmes-    , scope <- Vector.toList (resourceMetricsScopes rme)-    , export <- Vector.toList (scopeMetricsExports scope)-    , MetricExportHistogram n _ _ _ _ pts <- [export]-    , p <- Vector.toList pts-    ]---- ===========================================================================--- EP-51 sharded-subscription test helpers--- ===========================================================================---- A test sink the sharded handlers write to: one row per processed event,--- idempotent on event_id (an at-least-once handler may redeliver during a--- rebalance). worker_tag identifies which worker process handled it; stream_id--- is the originating stream (the partition key kiroku hashes on).-createShardSinkSql :: ByteString-createShardSinkSql =-    "CREATE TABLE IF NOT EXISTS shard_sink \-    \(event_id uuid PRIMARY KEY, worker_tag int NOT NULL, stream_id bigint NOT NULL)"---- Seed @nStreams@ category-@orders@ streams with @perStream@ events each--- (upsert append, so it is safe to call twice in one test). Returns the total--- number of events appended.-seedOrders :: Store.KirokuStore -> Int -> Int -> IO Int-seedOrders store nStreams perStream = do-    for_ [0 .. nStreams - 1] $ \i -> do-        let sname = StreamName ("orders-" <> Text.pack (show i))-            evs =-                [ EventData-                    { eventId = Nothing-                    , eventType = EventType "OrderPlaced"-                    , payload = object ["n" Aeson..= (j :: Int)]-                    , metadata = Nothing-                    , causationId = Nothing-                    , correlationId = Nothing-                    }-                | j <- [0 .. perStream - 1]-                ]-        Right _ <- Store.runStoreIO store $ Store.appendToStream sname AnyVersion evs-        pure ()-    pure (nStreams * perStream)---- A handler for worker @tag@: idempotently record (event_id, tag, stream_id).-sinkHandler :: Store.KirokuStore -> Int32 -> RecordedEvent -> IO ()-sinkHandler store tag ev =-    void $-        Store.runStoreIO store $-            Store.runTransaction $-                Tx.statement (eventUuid (ev ^. #eventId), tag, streamIdInt (ev ^. #originalStreamId)) insertShardSinkStmt-  where-    eventUuid (EventId u) = u-    streamIdInt (StreamId s) = s--insertShardSinkStmt :: Statement (UUID, Int32, Int64) ()-insertShardSinkStmt =-    preparable-        "INSERT INTO shard_sink (event_id, worker_tag, stream_id) VALUES ($1, $2, $3) ON CONFLICT (event_id) DO NOTHING"-        ( contrazip3-            (E.param (E.nonNullable E.uuid))-            (E.param (E.nonNullable E.int4))-            (E.param (E.nonNullable E.int8))-        )-        D.noResult--shardSinkCount :: Store.KirokuStore -> IO Int-shardSinkCount store =-    either (const 0) id-        <$> Store.runStoreIO store (Store.runTransaction (Tx.statement () countShardSinkStmt))--countShardSinkStmt :: Statement () Int-countShardSinkStmt =-    preparable-        "SELECT count(*) FROM shard_sink"-        E.noParams-        (D.singleRow (fromIntegral <$> D.column (D.nonNullable D.int8)))--shardDeadLetterDetails :: Store.KirokuStore -> Text -> IO (Int, Maybe Text, Maybe Int)-shardDeadLetterDetails store subscription =-    either (const (0, Nothing, Nothing)) id-        <$> Store.runStoreIO store (Store.runTransaction (Tx.statement subscription shardDeadLetterDetailsStmt))--shardDeadLetterDetailsStmt :: Statement Text (Int, Maybe Text, Maybe Int)-shardDeadLetterDetailsStmt =-    preparable-        "SELECT count(*)::bigint, max(reason_summary), max(attempt_count) \-        \FROM kiroku.dead_letters \-        \WHERE subscription_name = $1 AND consumer_group_member = 0"-        (E.param (E.nonNullable E.text))-        ( D.singleRow $-            (,,)-                <$> (fromIntegral <$> D.column (D.nonNullable D.int8))-                <*> D.column (D.nullable D.text)-                <*> (fmap fromIntegral <$> D.column (D.nullable D.int4))-        )---- The largest number of distinct workers that processed any single stream. 1--- means perfectly disjoint ownership (no stream split across workers).-maxWorkersPerStream :: Store.KirokuStore -> IO Int-maxWorkersPerStream store =-    either (const 0) id-        <$> Store.runStoreIO store (Store.runTransaction (Tx.statement () maxWorkersPerStreamStmt))--maxWorkersPerStreamStmt :: Statement () Int-maxWorkersPerStreamStmt =-    preparable-        "SELECT COALESCE(MAX(c), 0) FROM \-        \(SELECT count(DISTINCT worker_tag) AS c FROM shard_sink GROUP BY stream_id) s"-        E.noParams-        (D.singleRow (fromIntegral <$> D.column (D.nonNullable D.int8)))---- How many distinct workers processed at least one event (proves the work--- spread across the pool rather than monopolised by one worker).-distinctWorkers :: Store.KirokuStore -> IO Int-distinctWorkers store =-    either (const 0) id-        <$> Store.runStoreIO store (Store.runTransaction (Tx.statement () distinctWorkersStmt))--distinctWorkersStmt :: Statement () Int-distinctWorkersStmt =-    preparable-        "SELECT count(DISTINCT worker_tag) FROM shard_sink"-        E.noParams-        (D.singleRow (fromIntegral <$> D.column (D.nonNullable D.int8)))---- Poll the sink count until it reaches @target@ or the timeout elapses.-waitUntilSinkCount :: Store.KirokuStore -> Int -> Int -> IO Bool-waitUntilSinkCount store target timeoutMicros = go (max 1 (timeoutMicros `div` step))-  where-    step = 100_000-    go :: Int -> IO Bool-    go 0 = (>= target) <$> shardSinkCount store-    go n = do-        c <- shardSinkCount store-        if c >= target-            then pure True-            else threadDelay step >> go (n - 1)---- Poll until at least @target@ shard rows have a live owner. Tests use this to--- join a second worker at a precise point in the one-bucket-per-pass ramp-up.-waitUntilOwnedShardCount :: Store.KirokuStore -> SubscriptionName -> Int -> Int -> IO Bool-waitUntilOwnedShardCount store sub target timeoutMicros = go (max 1 (timeoutMicros `div` step))-  where-    step = 50_000-    go 0 = hasTarget-    go n = do-        reached <- hasTarget-        if reached then pure True else threadDelay step >> go (n - 1)-    hasTarget = do-        rows <- either (const []) id <$> Store.runStoreIO store (Store.runTransaction (listShardOwnership sub))-        pure (length [() | (_, Just _, _) <- rows] >= target)---- Poll the lease table until cooperative ownership has converged: every bucket--- owned, at least @minWorkers@ distinct owners, and no owner holding more than--- its fair share. This is the "balanced on the empty category" gate the--- failover test waits on before seeding, so the drain runs under stable--- membership.-waitShardsBalanced :: Store.KirokuStore -> SubscriptionName -> Int -> Int -> Int -> IO Bool-waitShardsBalanced store sub n minWorkers timeoutMicros = go (max 1 (timeoutMicros `div` step))-  where-    step = 200_000-    go :: Int -> IO Bool-    go 0 = isBalanced-    go k = do-        ok <- isBalanced-        if ok then pure True else threadDelay step >> go (k - 1)-    isBalanced :: IO Bool-    isBalanced = do-        rows <- either (const []) id <$> Store.runStoreIO store (Store.runTransaction (listShardOwnership sub))-        let owners = [w | (_, Just w, _) <- rows]-            distinct = length (nubOrd owners)-            perOwner = [length g | g <- groupByOwner owners]-            fairShare = (n + max 1 distinct - 1) `div` max 1 distinct-        pure (length rows == n && length owners == n && distinct >= minWorkers && all (<= fairShare) perOwner)-    groupByOwner ws = [filter (== w) ws | w <- nubOrd ws]-    nubOrd = Set.toList . Set.fromList--waitShardsUnowned :: Store.KirokuStore -> SubscriptionName -> Int -> Int -> IO Bool-waitShardsUnowned store sub n timeoutMicros = go (max 1 (timeoutMicros `div` step))-  where-    step = 100_000-    go 0 = isUnowned-    go k = do-        ok <- isUnowned-        if ok then pure True else threadDelay step >> go (k - 1)-    isUnowned = do-        rows <- either (const []) id <$> Store.runStoreIO store (Store.runTransaction (listShardOwnership sub))-        pure (length rows == n && all (\(_, owner, _) -> isNothing owner) rows)--workflowOwnedRowCounts :: (Store :> es) => Text -> Text -> Eff es (Int64, Int64, Int64, Int64, Int64, Int64)-workflowOwnedRowCounts name wid =-    Store.runTransaction (Tx.statement (wid, name) workflowOwnedRowCountsStmt)--workflowOwnedChildCount :: (Store :> es) => Text -> Text -> Eff es Int64-workflowOwnedChildCount name wid =-    Store.runTransaction (Tx.statement (wid, name, wid, name) workflowOwnedChildCountStmt)--workflowWakeAfter :: (Store :> es) => WorkflowName -> WorkflowId -> Eff es (Maybe UTCTime)-workflowWakeAfter (WorkflowName name) (WorkflowId wid) =-    Store.runTransaction (Tx.statement (wid, name) workflowWakeAfterStmt)--insertGcTimerStmt :: Statement (UUID, Text, Text, UTCTime, Value, Text) ()-insertGcTimerStmt =-    preparable-        """-        INSERT INTO keiro.keiro_timers-          (timer_id, process_manager_name, correlation_id, fire_at, payload, status)-        VALUES ($1, $2, $3, $4, $5, $6)-        """-        ( contrazip6-            (E.param (E.nonNullable E.uuid))-            (E.param (E.nonNullable E.text))-            (E.param (E.nonNullable E.text))-            (E.param (E.nonNullable E.timestamptz))-            (E.param (E.nonNullable E.jsonb))-            (E.param (E.nonNullable E.text))-        )-        D.noResult--deleteGcStepsStmt :: Statement (Text, Text) ()-deleteGcStepsStmt =-    preparable-        """-        DELETE FROM keiro.keiro_workflow_steps-        WHERE workflow_id = $1 AND workflow_name = $2-        """-        ( contrazip2-            (E.param (E.nonNullable E.text))-            (E.param (E.nonNullable E.text))-        )-        D.noResult--deleteWorkflowInstanceStmt :: Statement (Text, Text) ()-deleteWorkflowInstanceStmt =-    preparable-        """-        DELETE FROM keiro.keiro_workflows-        WHERE workflow_id = $1 AND workflow_name = $2-        """-        ( contrazip2-            (E.param (E.nonNullable E.text))-            (E.param (E.nonNullable E.text))-        )-        D.noResult--workflowWakeAfterStmt :: Statement (Text, Text) (Maybe UTCTime)-workflowWakeAfterStmt =-    preparable-        """-        SELECT wake_after-        FROM keiro.keiro_workflows-        WHERE workflow_id = $1 AND workflow_name = $2-        """-        ( contrazip2-            (E.param (E.nonNullable E.text))-            (E.param (E.nonNullable E.text))-        )-        (maybe Nothing id <$> D.rowMaybe (D.column (D.nullable D.timestamptz)))--workflowOwnedRowCountsStmt :: Statement (Text, Text) (Int64, Int64, Int64, Int64, Int64, Int64)-workflowOwnedRowCountsStmt =-    preparable-        """-        SELECT-          (SELECT count(*) FROM keiro.keiro_workflows WHERE workflow_id = $1 AND workflow_name = $2),-          (SELECT count(*) FROM keiro.keiro_workflow_steps WHERE workflow_id = $1 AND workflow_name = $2),-          (SELECT count(*) FROM keiro.keiro_awakeables WHERE owner_workflow_id = $1 AND owner_workflow_name = $2),-          (SELECT count(*) FROM keiro.keiro_workflow_children-            WHERE (parent_id = $1 AND parent_name = $2) OR (child_id = $1 AND child_name = $2)),-          (SELECT count(*) FROM keiro.keiro_timers-            WHERE correlation_id = $1 AND process_manager_name = $2 AND payload->>'kind' = 'keiro.workflow.sleep'),-          (SELECT count(*)-             FROM keiro.keiro_snapshots s-             JOIN streams st ON st.stream_id = s.stream_id-            WHERE st.stream_name = 'wf:' || $2 || '-' || $1)-        """-        ( contrazip2-            (E.param (E.nonNullable E.text))-            (E.param (E.nonNullable E.text))-        )-        ( D.singleRow $-            (,,,,,)-                <$> D.column (D.nonNullable D.int8)-                <*> D.column (D.nonNullable D.int8)-                <*> D.column (D.nonNullable D.int8)-                <*> D.column (D.nonNullable D.int8)-                <*> D.column (D.nonNullable D.int8)-                <*> D.column (D.nonNullable D.int8)-        )--workflowOwnedChildCountStmt :: Statement (Text, Text, Text, Text) Int64-workflowOwnedChildCountStmt =-    preparable-        """-        SELECT count(*)-        FROM keiro.keiro_workflow_children-        WHERE (parent_id = $1 AND parent_name = $2)-           OR (child_id = $3 AND child_name = $4)-        """-        ( contrazip4-            (E.param (E.nonNullable E.text))-            (E.param (E.nonNullable E.text))-            (E.param (E.nonNullable E.text))-            (E.param (E.nonNullable E.text))-        )-        (D.singleRow (D.column (D.nonNullable D.int8)))+module Main+  ( main,+  )+where++import Contravariant.Extras (contrazip2, contrazip3, contrazip4, contrazip5, contrazip6)+import Control.Concurrent (forkIO, killThread, threadDelay)+import Control.Concurrent.MVar (MVar, modifyMVar, newEmptyMVar, newMVar, putMVar, readMVar, takeMVar, tryPutMVar)+import Control.Concurrent.STM (atomically, putTMVar)+import Control.Exception (ErrorCall, Exception, SomeException, displayException, evaluate, finally, throwIO, try)+import Data.Aeson (object, withObject, (.:), (.:?))+import Data.Aeson qualified as Aeson+import Data.Aeson.KeyMap qualified as KeyMap+import Data.Aeson.Types (parseEither)+import Data.ByteString (ByteString)+import Data.IORef (IORef, atomicModifyIORef', modifyIORef', newIORef, readIORef, writeIORef)+import Data.Int (Int32)+import Data.List (isInfixOf)+import Data.Map.Strict qualified as Map+import Data.Monoid (mempty)+import Data.Set qualified as Set+import Data.Text qualified as Text+import Data.Text.Encoding qualified as TE+import Data.Time (NominalDiffTime, UTCTime (..), addUTCTime, diffUTCTime, secondsToDiffTime)+import Data.Time.Calendar (Day (ModifiedJulianDay))+import Data.UUID (UUID, fromString, fromWords64)+import Data.UUID qualified as UUID+import Data.Vector qualified as Vector+import Data.Word (Word64)+import Effectful (Eff, IOE, (:>))+import Effectful.Error.Static (Error, throwError)+import Effectful.Exception qualified as EffException+import GHC.Conc (ThreadStatus (..), threadStatus)+import Hasql.Decoders qualified as D+import Hasql.Encoders qualified as E+import Hasql.Statement (Statement, preparable)+import Keiki.Core+  ( Edge (..),+    HsPred (..),+    InCtor (..),+    IndexN,+    RegFile (..),+    SymTransducer (..),+    Update (..),+    WireCtor (..),+    inpCtor,+    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.EventStream (Terminality (..))+import Keiro.EventStream.Validate+  ( EventStreamWarning (..),+    ValidatedEventStream,+    mkEventStream,+    mkEventStreamOrThrow,+    mkEventStreamUnchecked,+    mkEventStreamWith,+    validateEventStream,+  )+import Keiro.Inbox+  ( InboxDedupePolicy (..),+    InboxError (..),+    InboxPersistence (..),+    InboxResult (..),+    InboxStatus (..),+    KafkaDeliveryRef (..),+    garbageCollectCompleted,+    listInbox,+    lookupInbox,+    markFailedTx,+    runInboxTransaction,+    runInboxTransactionBatch,+    runInboxTransactionWith,+    runInboxTransactionWithRetries,+    runInboxTransactionWithRetriesWith,+    sampleInboxBacklog,+  )+import Keiro.Inbox.Kafka qualified as InboxKafka+import Keiro.Integration.Event+  ( IntegrationContentType (..),+    IntegrationEvent (..),+    SchemaReference (..),+    TraceContext (..),+    decodeJsonIntegrationEvent,+    encodeJsonIntegrationEvent,+    headerContentType,+    headerMessageId,+    headerSchemaSubject,+    headerSchemaVersion,+    headerSourceEventId,+    headerSourceGlobalPosition,+    headerTraceParent,+    integrationHeaders,+    integrationPayload,+    parseContentType,+  )+import Keiro.Integration.Event qualified as IntegrationEvent+import Keiro.Outbox+  ( BackoffSchedule (..),+    ExponentialBackoffOptions (..),+    IntegrationEventDraft (..),+    IntegrationProducer (..),+    IntegrationProducerConfigError (..),+    OrderingPolicy (..),+    OutboxId (..),+    OutboxPublishConfigError (..),+    OutboxRow (..),+    OutboxStatus (..),+    PublishOutcome (..),+    claimOutboxBatch,+    defaultMaintenanceOptions,+    defaultPublishOptions,+    draftToEvent,+    enqueueIntegrationEventTx,+    freshOutboxId,+    garbageCollectSent,+    lookupOutbox,+    markOutboxSent,+    mintIntegrationEvent,+    mkIntegrationProducer,+    mkOutboxPublishOptions,+    outboxMaintenancePass,+    publishClaimedOutbox,+    sampleOutboxBacklog,+  )+import Keiro.Outbox.Kafka qualified as OutboxKafka+import Keiro.Outbox.Schema (markOutboxFailedTx)+import Keiro.Prelude+import Keiro.ProcessManager+import Keiro.Projection+import Keiro.ReadModel+import Keiro.ReadModel.Rebuild qualified as Rebuild+import Keiro.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 (..),+    withFreshResourceStore,+    withFreshResourceStoreWith,+    withFreshStore,+    withFreshStoreWith,+    withFreshStores2,+    withMigratedSuite,+  )+import Keiro.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,+    continueAsNew,+    currentGeneration,+    defaultWorkflowRunOptions,+    findUnfinishedWorkflowIds,+    loadStepIndex,+    mkWorkflowId,+    mkWorkflowName,+    patch,+    patchSetStepName,+    patchStepName,+    restoreSeed,+    runWorkflow,+    runWorkflowWith,+    step,+    stepExists,+    workflowGenerationStreamName,+    workflowJournalCodec,+  )+import Keiro.Workflow.Awakeable+  ( AwakeableId (..),+    WorkflowAwakeableCancelled (..),+    awakeableIdText,+    awakeableIdToUuid,+    awakeableNamed,+    cancelAwakeable,+    deterministicAwakeableId,+    signalAwakeable,+    signalAwakeableFrom,+  )+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+  ( 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 OpenTelemetry.Attributes (Attribute (..), Attributes, PrimitiveAttribute (..), lookupAttribute)+import OpenTelemetry.Attributes.Key (AttributeKey, unkey)+import OpenTelemetry.Exporter.InMemory.Metric (inMemoryMetricExporter)+import OpenTelemetry.Exporter.InMemory.Span (inMemoryListExporter)+import OpenTelemetry.Exporter.Metric+  ( GaugeDataPoint (..),+    HistogramDataPoint (..),+    MetricExport (..),+    NumberValue (..),+    ResourceMetricsExport (..),+    ScopeMetricsExport (..),+    SumDataPoint (..),+  )+import OpenTelemetry.MeterProvider+  ( SdkMeterProviderOptions (..),+    createMeterProvider,+    defaultSdkMeterProviderOptions,+  )+import OpenTelemetry.Metric.Core+  ( forceFlushMeterProvider,+    getMeter,+  )+import OpenTelemetry.Resource (emptyMaterializedResources)+import OpenTelemetry.Trace+  ( SpanStatus (..),+    createTracerProvider,+    emptyTracerProviderOptions,+    makeTracer,+    shutdownTracerProvider,+    tracerOptions,+  )+import OpenTelemetry.Trace.Core+  ( ImmutableSpan (..),+    Span,+    SpanContext (..),+    SpanHot (..),+    SpanKind,+    getSpanContext,+  )+import Shibuya.Adapter (Adapter (..))+import Shibuya.Core.Ack (AckDecision (..), DeadLetterReason (..), HaltReason (..), RetryDelay (..))+import Shibuya.Core.AckHandle (AckHandle (..))+import Shibuya.Core.Ingested (Ingested (..))+import Shibuya.Core.Types (Envelope (..))+import Streamly.Data.Stream qualified as Streamly+import System.Exit (ExitCode (..))+import System.Process (readProcessWithExitCode)+import System.Timeout (timeout)+import Test.Hspec+import "hasql-transaction" Hasql.Transaction qualified as Tx++main :: IO ()+main = withMigratedSuite $ \fixture -> hspec $ do+  describe "Keiro" $ do+    it "exposes the scaffold version" $+      KeiroRoot.version `shouldBe` ("0.4.0.0" :: Text)++  describe "Keiro.Telemetry metrics" $ do+    it "records instrument names and values through an SDK meter" $ do+      (exporter, ref) <- inMemoryMetricExporter+      (provider, _env) <-+        createMeterProvider+          emptyMaterializedResources+          defaultSdkMeterProviderOptions {metricExporter = Just exporter}+      meter <- getMeter provider Telemetry.keiroInstrumentationLibrary+      metrics <- Telemetry.newKeiroMetrics meter+      let h = Just metrics+      -- A counter (monotonic sum), a gauge (last value wins), a histogram.+      Telemetry.recordOutboxPublished h 3+      Telemetry.recordOutboxPublished h 2+      Telemetry.recordOutboxBacklog h 7+      Telemetry.recordInboxDuplicates h 1+      Telemetry.recordTimerFireLag h 12.5+      _ <- forceFlushMeterProvider provider Nothing+      exported <- readIORef ref+      let scalars = flattenScalarPoints exported+          hists = flattenHistogramPoints exported+      -- The counter accumulated 3 + 2 = 5.+      lookup "keiro.outbox.published" scalars `shouldBe` Just (IntNumber 5)+      -- The gauge holds its last recorded value.+      lookup "keiro.outbox.backlog" scalars `shouldBe` Just (IntNumber 7)+      -- The duplicate counter holds 1.+      lookup "keiro.inbox.duplicates" scalars `shouldBe` Just (IntNumber 1)+      -- The histogram saw one observation summing to 12.5.+      let lag = [(c, s) | (n, c, s) <- hists, n == "keiro.timer.fire.lag"]+      lag `shouldBe` [(1, 12.5)]+      -- Instruments we never recorded export no points.+      lookup "keiro.timer.stuck" scalars `shouldBe` Nothing++    it "records nothing through a Nothing handle" $ do+      (exporter, ref) <- inMemoryMetricExporter+      (provider, _env) <-+        createMeterProvider+          emptyMaterializedResources+          defaultSdkMeterProviderOptions {metricExporter = Just exporter}+      -- A Nothing handle is the no-op path: helpers must short-circuit.+      let h = Nothing+      Telemetry.recordOutboxPublished h 99+      Telemetry.recordOutboxBacklog h 99+      Telemetry.recordTimerFireLag h 99.0+      _ <- forceFlushMeterProvider provider Nothing+      exported <- readIORef ref+      flattenScalarPoints exported `shouldBe` []+      flattenHistogramPoints exported `shouldBe` []++  describe "Kiroku retry exhaustion observability" $ do+    it "dead-letters after the configured delivery bound, emits the metric, and advances" $ do+      (exporter, metricsRef) <- inMemoryMetricExporter+      (provider, _env) <-+        createMeterProvider+          emptyMaterializedResources+          defaultSdkMeterProviderOptions {metricExporter = Just exporter}+      meter <- getMeter provider Telemetry.keiroInstrumentationLibrary+      metrics <- Telemetry.newKeiroMetrics meter+      forwarded <- newIORef (0 :: Int)+      let observe _ = modifyIORef' forwarded (+ 1)+          installBridge settings =+            settings+              & #eventHandler+              .~ Just (Telemetry.kirokuEventBridge (Just metrics) observe)+      withFreshStoreWith fixture installBridge $ \store -> do+        total <- seedOrders store 1 2+        total `shouldBe` 2+        let subName = SubscriptionName "orders-retry-exhaustion"+            subConfig =+              ( KirokuSub.defaultSubscriptionConfig+                  subName+                  (Category (CategoryName "orders"))+                  (\_ -> pure KirokuSub.Continue)+              )+                { KirokuSub.retryPolicy = KirokuSub.RetryPolicy 2+                }+            pull label source = do+              result <- timeout 5_000_000 (Streamly.uncons source)+              case result of+                Just (Just itemAndRest) -> pure itemAndRest+                Just Nothing -> fail (label <> ": subscription ended early")+                Nothing -> fail (label <> ": timed out waiting for delivery")+            number item =+              parseEither+                (withObject "OrderPlaced" (.: "n"))+                (ackEvent item ^. #payload)+        (stream0, cancelStream) <- subscriptionAckStream store subConfig 4+        ( do+            (first, stream1) <- pull "initial poison delivery" stream0+            ackAttempt first `shouldBe` 0+            number first `shouldBe` Right (0 :: Int)+            atomically $+              putTMVar+                (ackReply first)+                (KirokuSub.Retry (KirokuSub.RetryDelay 0))++            (retry, stream2) <- pull "poison redelivery" stream1+            ackAttempt retry `shouldBe` 1+            ackEvent retry ^. #eventId `shouldBe` ackEvent first ^. #eventId+            atomically $+              putTMVar+                (ackReply retry)+                (KirokuSub.Retry (KirokuSub.RetryDelay 0))++            (next, stream3) <- pull "event after exhausted poison" stream2+            ackAttempt next `shouldBe` 0+            number next `shouldBe` Right (1 :: Int)+            ackEvent next ^. #eventId `shouldNotBe` ackEvent first ^. #eventId+            atomically (putTMVar (ackReply next) KirokuSub.Stop)+            ended <- timeout 5_000_000 (Streamly.uncons stream3)+            case ended of+              Just Nothing -> pure ()+              Just (Just _) -> expectationFailure "subscription delivered after Stop"+              Nothing -> expectationFailure "subscription did not stop after the final acknowledgement"+          )+          `finally` cancelStream++        Right rows <-+          Store.runStoreIO store $+            Store.runTransaction $+              Tx.statement+                ("orders-retry-exhaustion", 0)+                KirokuSQL.readDeadLettersStmt+        case Vector.toList rows of+          [row] -> do+            row ^. #deadLetterReason+              `shouldBe` object+                [ "kind" Aeson..= ("max_attempts_exceeded" :: Text),+                  "attempts" Aeson..= (2 :: Int)+                ]+            row ^. #deadLetterReasonSummary `shouldBe` "max retry attempts exceeded (2)"+            row ^. #deadLetterAttemptCount `shouldBe` 2+          other -> expectationFailure ("expected one Kiroku dead letter, got " <> show (Vector.length rows) <> ": " <> show other)++        _ <- forceFlushMeterProvider provider Nothing+        exported <- readIORef metricsRef+        lookup "keiro.subscription.deadlettered" (flattenScalarPoints exported)+          `shouldBe` Just (IntNumber 1)+        readIORef forwarded >>= (`shouldSatisfy` (> 1))++  describe "Keiro.Stream" $ do+    it "wraps and unwraps kiroku stream names" $ do+      let orderStream = stream "order-123" :: Stream OrderStream+      Stream.streamName orderStream `shouldBe` StreamName "order-123"+      Stream.streamName (mapStreamName (\(StreamName name) -> StreamName (name <> "-archived")) orderStream)+        `shouldBe` StreamName "order-123-archived"++    it "validates categories, rejecting the dash boundary and reserved names" $ do+      fmap Stream.categoryText (Stream.category "incident" :: Either Stream.CategoryError (Stream.StreamCategory ()))+        `shouldBe` Right "incident"+      -- compound categories are camelCase; ':' (reserved for the wf: family) is also accepted+      fmap Stream.categoryText (Stream.category "hospitalSurge" :: Either Stream.CategoryError (Stream.StreamCategory ()))+        `shouldBe` Right "hospitalSurge"+      fmap Stream.categoryText (Stream.category "wf:fulfillment" :: Either Stream.CategoryError (Stream.StreamCategory ()))+        `shouldBe` Right "wf:fulfillment"+      (Stream.category "" :: Either Stream.CategoryError (Stream.StreamCategory ()))+        `shouldBe` Left Stream.CategoryEmpty+      (Stream.category "hospital-surge" :: Either Stream.CategoryError (Stream.StreamCategory ()))+        `shouldBe` Left (Stream.CategoryContainsSeparator "hospital-surge")+      (Stream.category "$all" :: Either Stream.CategoryError (Stream.StreamCategory ()))+        `shouldBe` Left (Stream.CategoryReserved "$all")+      (Stream.category "ord ers" :: Either Stream.CategoryError (Stream.StreamCategory ()))+        `shouldBe` Left (Stream.CategoryContainsIllegalChar ' ' "ord ers")+      (Stream.category "ord\ners" :: Either Stream.CategoryError (Stream.StreamCategory ()))+        `shouldBe` Left (Stream.CategoryContainsIllegalChar '\n' "ord\ners")++    it "builds entity streams that round-trip through kiroku's category rule" $ do+      let cat = Stream.categoryUnsafe "orders" :: Stream.StreamCategory OrderStream+      Stream.streamName (Stream.entityStream cat "1") `shouldBe` StreamName "orders-1"+      Stream.categoryName cat `shouldBe` CategoryName "orders"+      -- The category keiro reports equals kiroku's own parse of the produced+      -- name, even when the id segment itself contains a dash.+      Store.categoryName (Stream.streamName (Stream.entityStream cat "a-b-c"))+        `shouldBe` Stream.categoryName cat++    it "entityStreamId renders ids via StreamIdSegment (Text and String)" $ do+      let cat = Stream.categoryUnsafe "orders" :: Stream.StreamCategory OrderStream+      Stream.streamName (Stream.entityStreamId cat ("o-1" :: Text)) `shouldBe` StreamName "orders-o-1"+      Stream.streamName (Stream.entityStreamId cat ("o-1" :: String)) `shouldBe` StreamName "orders-o-1"++    it "rejects blank entity stream id segments" $ do+      let cat = Stream.categoryUnsafe "orders" :: Stream.StreamCategory OrderStream+      evaluate (Stream.streamName (Stream.entityStream cat "")) `shouldThrow` anyErrorCall+      evaluate (Stream.streamName (Stream.entityStream cat "   ")) `shouldThrow` anyErrorCall++  describe "Keiro.DeadLetter" $ around (withFreshStore fixture) $ do+    it "records a dispatch dead letter idempotently" $ \storeHandle -> do+      let deadLetter =+            DispatchDeadLetter+              { dispatcherKind = DispatcherProcessManager,+                dispatcherName = "orders-pm",+                correlationId = "order-42",+                sourceEventId = EventId sampleUuid,+                sourceGlobalPosition = GlobalPosition 17,+                emitIndex = 0,+                targetStreamName = StreamName "orders-42",+                errorClass = "command_rejected",+                errorDetail = Text.replicate 1100 "x",+                attemptCount = 2+              }+      Right rows <-+        Store.runStoreIO storeHandle $ do+          recordDispatchDeadLetter deadLetter+          recordDispatchDeadLetter deadLetter+          listDispatchDeadLetters "orders-pm"+      case rows of+        [row] -> do+          row ^. #dispatcherKind `shouldBe` DispatcherProcessManager+          row ^. #dispatcherName `shouldBe` "orders-pm"+          row ^. #correlationId `shouldBe` "order-42"+          row ^. #sourceEventId `shouldBe` EventId sampleUuid+          row ^. #sourceGlobalPosition `shouldBe` GlobalPosition 17+          row ^. #emitIndex `shouldBe` 0+          row ^. #targetStreamName `shouldBe` StreamName "orders-42"+          row ^. #errorClass `shouldBe` "command_rejected"+          Text.length (row ^. #errorDetail) `shouldBe` 1024+          row ^. #attemptCount `shouldBe` 2+        other -> expectationFailure ("expected one idempotent dead-letter row, got " <> show other)++  describe "Keiro.Codec" $ do+    it "encodes current events with type tags and schema-version metadata" $ do+      encoded <- shouldBeRight (encodeForAppend orderCodec (OrderPlaced "order-123" 5))+      encoded ^. #eventType `shouldBe` EventType "OrderPlaced"+      encoded ^. #payload `shouldBe` object ["orderId" Aeson..= ("order-123" :: Text), "quantity" Aeson..= (5 :: Int)]+      extractSchemaVersion (recordedFrom encoded) `shouldBe` Right 2++    it "round-trips current events" $ do+      encoded <- shouldBeRight (encodeForAppend orderCodec (OrderPlaced "order-123" 5))+      decodeRecorded orderCodec (recordedFrom encoded) `shouldBe` Right (OrderPlaced "order-123" 5)++    it "decodes by the stored tag, not by payload shape (H1)" $ do+      let recorded =+            recordedFrom+              EventData+                { eventId = Nothing,+                  eventType = EventType "CounterAudited",+                  payload = object ["amount" Aeson..= (5 :: Int)],+                  metadata = Just (metadataForOrDie 1 Nothing),+                  causationId = Nothing,+                  correlationId = Nothing+                }+      decodeRecorded counterCodec recorded `shouldBe` Right (CounterAudited 5)++    it "runs upcasters in source-version order" $+      decodeRaw orderCodec (EventType "OrderPlaced") 1 (object ["orderId" Aeson..= ("order-123" :: Text), "qty" Aeson..= (5 :: Int)])+        `shouldBe` Right (OrderPlaced "order-123" 5)++    it "rejects gaps in upcaster chains" $+      decodeRaw gappyCodec (EventType "OrderPlaced") 1 (object ["orderId" Aeson..= ("order-123" :: Text), "qty" Aeson..= (5 :: Int)])+        `shouldBe` Left (GapInUpcasterChain 2 3)++    it "validates codec construction invariants" $ do+      fmap (const ()) (mkCodec (orderCodec {schemaVersion = 0})) `shouldBe` Left (CodecSchemaVersionInvalid 0)+      fmap (const ()) (mkCodec (orderCodec {eventTypes = EventType "OrderPlaced" :| [EventType "OrderPlaced"]}))+        `shouldBe` Left (CodecDuplicateEventTypes [EventType "OrderPlaced"])+      fmap (const ()) (mkCodec (orderCodec {schemaVersion = 3, upcasters = [(1, const upcastOrderPlacedV1), (1, const upcastOrderPlacedV1)]}))+        `shouldBe` Left (CodecDuplicateUpcasterSources [1])+      fmap (const ()) (mkCodec (orderCodec {schemaVersion = 3, upcasters = [(1, const upcastOrderPlacedV1)]}))+        `shouldBe` Left (CodecUpcasterChainIncomplete [2] 3)+      case mkCodec orderCodec of+        Right _ -> pure ()+        Left err -> expectationFailure ("expected orderCodec to validate, got " <> show err)++    it "rejects future-version, malformed metadata, and incomplete upcaster chains" $ do+      let v1Payload = object ["orderId" Aeson..= ("order-123" :: Text), "qty" Aeson..= (5 :: Int)]+          earlyEndCodec =+            orderCodec+              { schemaVersion = 4,+                upcasters = [(1, const upcastOrderPlacedV1), (2, const Right)]+              }+      decodeRaw orderCodec (EventType "OrderPlaced") 3 v1Payload+        `shouldBe` Left (VersionAhead 3 2)+      decodeRaw earlyEndCodec (EventType "OrderPlaced") 1 v1Payload+        `shouldBe` Left (IncompleteUpcasterChain 3 4)++      let malformedStamp =+            recordedFrom+              EventData+                { eventId = Nothing,+                  eventType = EventType "OrderPlaced",+                  payload = object ["orderId" Aeson..= ("order-123" :: Text), "quantity" Aeson..= (5 :: Int)],+                  metadata = Just (object ["schemaVersion" Aeson..= ("2" :: Text)]),+                  causationId = Nothing,+                  correlationId = Nothing+                }+      extractSchemaVersion malformedStamp+        `shouldBe` Left (MalformedSchemaVersionStamp (Aeson.String "2"))+      fmap (const ()) (encodeForAppendWithMetadata orderCodec (Just (Aeson.String "x")) (OrderPlaced "order-123" 5))+        `shouldBe` Left (NonObjectCallerMetadata (Aeson.String "x"))++    it "rejects recorded events with unknown type tags" $ do+      let encoded =+            recordedFrom+              EventData+                { eventId = Nothing,+                  eventType = EventType "OrderCancelled",+                  payload = object ["orderId" Aeson..= ("order-123" :: Text)],+                  metadata = Just (metadataForOrDie 2 Nothing),+                  causationId = Nothing,+                  correlationId = Nothing+                }+      decodeRecorded orderCodec encoded+        `shouldBe` Left (UnknownEventType (EventType "OrderCancelled") [EventType "OrderPlaced"])++  describe "Keiro.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",+            "test/ReplaySafetyTypeProbe.hs"+          ]+          ""+      exitCode `shouldSatisfy` (/= ExitSuccess)+      stderr `shouldSatisfy` ("ValidatedEventStream" `isInfixOf`)++  describe "Keiro.Command" $ around (withFreshStore fixture) $ do+    it "creates a stream and appends the first command event" $ \storeHandle -> do+      let target = stream "counter-command-create" :: Stream CounterEventStream+      result <-+        Store.runStoreIO storeHandle $+          runCommand defaultRunCommandOptions counterEventStream target (Add 2)+      case result of+        Right (Right commandResult) -> do+          commandResult ^. #streamVersion `shouldBe` StreamVersion 1+          commandResult ^. #eventsAppended `shouldBe` 1+          commandResult ^. #globalPosition `shouldSatisfy` isJust+        other -> expectationFailure ("expected successful command, got " <> show other)+      Right recorded <-+        Store.runStoreIO storeHandle $+          Store.readStreamForward (StreamName "counter-command-create") (StreamVersion 0) 10+      Vector.length recorded `shouldBe` 1+      traverse (decodeRecorded counterCodec) (Vector.toList recorded)+        `shouldBe` Right [CounterAdded 2]++    it "reports no global position for a no-op after prior events" $ \storeHandle -> do+      let target = stream "skip-command-no-op-position" :: Stream SkipEventStream+      Right (Right appended) <-+        Store.runStoreIO storeHandle $+          runCommand defaultRunCommandOptions skipEventStream target (SAdd 2)+      appended ^. #globalPosition `shouldSatisfy` isJust+      result <-+        Store.runStoreIO storeHandle $+          runCommand defaultRunCommandOptions skipEventStream target SSkip+      case result of+        Right (Right noOp) -> do+          noOp ^. #streamVersion `shouldBe` StreamVersion 1+          noOp ^. #eventsAppended `shouldBe` 0+          noOp ^. #globalPosition `shouldBe` Nothing+        other -> expectationFailure ("expected successful no-op command, got " <> show other)++    it "surfaces runtime edge ambiguity without appending" $ \storeHandle -> do+      (processor, spansRef) <- inMemoryListExporter+      provider <- createTracerProvider [processor] emptyTracerProviderOptions+      let tracer = makeTracer provider "keiro-test" tracerOptions+          target = stream "counter-command-ambiguous" :: Stream CounterEventStream+          options = defaultRunCommandOptions & #tracer ?~ tracer+      result <-+        Store.runStoreIO storeHandle $+          runCommand options ambiguousCounterEventStream target (Add 1)+      _ <- shutdownTracerProvider provider Nothing+      result `shouldBe` Right (Left (CommandAmbiguous [0, 1]))+      Right recorded <-+        Store.runStoreIO storeHandle $+          Store.readStreamForward (StreamName "counter-command-ambiguous") (StreamVersion 0) 10+      recorded `shouldBe` Vector.empty+      spans <- traverse captureSpan =<< readIORef spansRef+      case spans of+        [sp] -> textAttr (csAttributes sp) "error.type" `shouldBe` Just "command_ambiguous"+        other -> expectationFailure ("expected one span, got " <> show (length other))++    it "rehydrates prior events before appending a second command event" $ \storeHandle -> do+      let target = stream "counter-command-update" :: Stream CounterEventStream+      Right (Right _) <-+        Store.runStoreIO storeHandle $+          runCommand defaultRunCommandOptions counterEventStream target (Add 2)+      result <-+        Store.runStoreIO storeHandle $+          runCommand defaultRunCommandOptions counterEventStream target (Add 3)+      case result of+        Right (Right commandResult) ->+          commandResult ^. #streamVersion `shouldBe` StreamVersion 2+        other -> expectationFailure ("expected successful second command, got " <> show other)+      Right recorded <-+        Store.runStoreIO storeHandle $+          Store.readStreamForward (StreamName "counter-command-update") (StreamVersion 0) 10+      traverse (decodeRecorded counterCodec) (Vector.toList recorded)+        `shouldBe` Right [CounterAdded 2, CounterAdded 3]++    it "rejects hydration after truncation without a covering snapshot" $ \storeHandle -> do+      let target = stream "counter-truncated-uncovered" :: Stream CounterEventStream+          targetName = StreamName "counter-truncated-uncovered"+      Right (Right _) <-+        Store.runStoreIO storeHandle $+          runCommand defaultRunCommandOptions counterEventStream target (Add 1)+      Right (Right _) <-+        Store.runStoreIO storeHandle $+          runCommand defaultRunCommandOptions counterEventStream target (Add 2)+      Right (Right _) <-+        Store.runStoreIO storeHandle $+          runCommand defaultRunCommandOptions counterEventStream target (Add 3)+      Right (Just _) <-+        Store.runStoreIO storeHandle $+          Store.setStreamTruncateBefore targetName (StreamVersion 3)+      result <-+        Store.runStoreIO storeHandle $+          runCommand defaultRunCommandOptions counterEventStream target (Add 4)+      case result of+        Right (Left (HydrationGapDetected expected observed)) -> do+          expected `shouldBe` StreamVersion 1+          observed `shouldBe` StreamVersion 3+        other -> expectationFailure ("expected HydrationGapDetected, got " <> show other)++    it "rejects hydration when truncation lands inside a command batch" $ \storeHandle -> do+      let target = stream "counter-truncated-mid-batch" :: Stream CounterEventStream+          targetName = StreamName "counter-truncated-mid-batch"+      Right (Right _) <-+        Store.runStoreIO storeHandle $+          runCommand defaultRunCommandOptions multiCounterEventStream target (Add 1)+      Right (Just _) <-+        Store.runStoreIO storeHandle $+          Store.setStreamTruncateBefore targetName (StreamVersion 2)+      result <-+        Store.runStoreIO storeHandle $+          runCommand defaultRunCommandOptions multiCounterEventStream target (Add 2)+      case result of+        Right (Left (HydrationGapDetected expected observed)) -> do+          expected `shouldBe` StreamVersion 1+          observed `shouldBe` StreamVersion 2+        other -> expectationFailure ("expected HydrationGapDetected, got " <> show other)++    it "hydrates normally after truncation covered by a snapshot" $ \storeHandle -> do+      let target = stream "counter-truncated-covered" :: Stream SnapshotCounterEventStream+          targetName = StreamName "counter-truncated-covered"+      Right (Right _) <-+        Store.runStoreIO storeHandle $+          runCommand defaultRunCommandOptions snapshotCounterEventStream target (Add 1)+      Right (Right _) <-+        Store.runStoreIO storeHandle $+          runCommand defaultRunCommandOptions snapshotCounterEventStream target (Add 2)+      Right (Just _) <-+        Store.runStoreIO storeHandle $+          Store.setStreamTruncateBefore targetName (StreamVersion 2)+      result <-+        Store.runStoreIO storeHandle $+          runCommand defaultRunCommandOptions snapshotCounterEventStream target (Add 3)+      case result of+        Right (Right commandResult) ->+          commandResult ^. #streamVersion `shouldBe` StreamVersion 3+        other -> expectationFailure ("expected snapshot-covered command success, got " <> show other)++    it "uses caller-supplied event ids for idempotent command batches" $ \storeHandle -> do+      let target = stream "counter-command-event-id" :: Stream CounterEventStream+          supplied = EventId sampleUuid2+          options = defaultRunCommandOptions & #eventIds .~ [supplied]+      result <-+        Store.runStoreIO storeHandle $+          runCommand options counterEventStream target (Add 7)+      case result of+        Right (Right commandResult) ->+          commandResult ^. #streamVersion `shouldBe` StreamVersion 1+        other -> expectationFailure ("expected successful command, got " <> show other)+      Right recorded <-+        Store.runStoreIO storeHandle $+          Store.readStreamForward (StreamName "counter-command-event-id") (StreamVersion 0) 10+      fmap (^. #eventId) (Vector.toList recorded) `shouldBe` [supplied]++    it "retries an optimistic conflict after rehydrating the winning event" $ \storeHandle -> do+      conflictInserted <- newIORef False+      let target = stream "counter-command-conflict" :: Stream CounterEventStream+          conflictStreamName = StreamName "counter-command-conflict"+          insertConflict = do+            shouldInsert <- atomicModifyIORef' conflictInserted $ \alreadyInserted ->+              if alreadyInserted+                then (True, False)+                else (True, True)+            when shouldInsert $ do+              encoded <- shouldBeRight (encodeForAppend counterCodec (CounterAdded 10))+              outcome <-+                Store.runStoreIO storeHandle $+                  Store.appendToStream conflictStreamName NoStream [encoded]+              case outcome of+                Right _ -> pure ()+                Left err -> expectationFailure ("failed to insert conflict event: " <> show err)+          options = defaultRunCommandOptions & #beforeAppend .~ insertConflict+      result <-+        Store.runStoreIO storeHandle $+          runCommand options counterEventStream target (Add 2)+      case result of+        Right (Right commandResult) -> do+          commandResult ^. #streamVersion `shouldBe` StreamVersion 2+          commandResult ^. #eventsAppended `shouldBe` 1+        other -> expectationFailure ("expected retry to succeed, got " <> show other)+      Right recorded <-+        Store.runStoreIO storeHandle $+          Store.readStreamForward conflictStreamName (StreamVersion 0) 10+      traverse (decodeRecorded counterCodec) (Vector.toList recorded)+        `shouldBe` Right [CounterAdded 10, CounterAdded 2]++    it "reports true retry attempts and command conflict metrics when the retry budget is exhausted" $ \storeHandle -> do+      (exporter, metricsRef) <- inMemoryMetricExporter+      (provider, _env) <-+        createMeterProvider+          emptyMaterializedResources+          defaultSdkMeterProviderOptions {metricExporter = Just exporter}+      meter <- getMeter provider Telemetry.keiroInstrumentationLibrary+      keiroMetrics <- Telemetry.newKeiroMetrics meter+      let target = stream "counter-command-exhausted-conflict" :: Stream CounterEventStream+          conflictStreamName = StreamName "counter-command-exhausted-conflict"+          insertConflict = do+            encoded <- shouldBeRight (encodeForAppend counterCodec (CounterAdded 10))+            outcome <-+              Store.runStoreIO storeHandle $+                Store.appendToStream conflictStreamName AnyVersion [encoded]+            case outcome of+              Right _ -> pure ()+              Left err -> expectationFailure ("failed to insert conflict event: " <> show err)+          options =+            defaultRunCommandOptions+              & #beforeAppend+              .~ insertConflict+              & #retryLimit+              .~ 2+              & #retryBackoffMicros+              .~ 0+              & #metrics+              ?~ keiroMetrics+      result <-+        Store.runStoreIO storeHandle $+          runCommand options counterEventStream target (Add 2)+      case result of+        Right (Left (RetryExhausted attempts _)) ->+          attempts `shouldBe` 3+        other -> expectationFailure ("expected exhausted retry budget, got " <> show other)+      _ <- forceFlushMeterProvider provider Nothing+      exported <- readIORef metricsRef+      let scalars = flattenScalarPoints exported+      lookup "keiro.command.conflicts" scalars `shouldBe` Just (IntNumber 3)+      lookup "keiro.command.retries" scalars `shouldBe` Just (IntNumber 2)++    it "records the successful retry attempt on the command span" $ \storeHandle -> do+      (processor, spansRef) <- inMemoryListExporter+      provider <- createTracerProvider [processor] emptyTracerProviderOptions+      conflictInserted <- newIORef False+      let tracer = makeTracer provider "keiro-test" tracerOptions+          target = stream "counter-command-retry-span" :: Stream CounterEventStream+          conflictStreamName = StreamName "counter-command-retry-span"+          insertConflict = do+            shouldInsert <- atomicModifyIORef' conflictInserted $ \alreadyInserted ->+              if alreadyInserted+                then (True, False)+                else (True, True)+            when shouldInsert $ do+              encoded <- shouldBeRight (encodeForAppend counterCodec (CounterAdded 10))+              outcome <-+                Store.runStoreIO storeHandle $+                  Store.appendToStream conflictStreamName NoStream [encoded]+              case outcome of+                Right _ -> pure ()+                Left err -> expectationFailure ("failed to insert conflict event: " <> show err)+          options =+            defaultRunCommandOptions+              & #beforeAppend+              .~ insertConflict+              & #retryBackoffMicros+              .~ 0+              & #tracer+              ?~ tracer+      Right (Right _) <-+        Store.runStoreIO storeHandle $+          runCommand options counterEventStream target (Add 2)+      _ <- shutdownTracerProvider provider Nothing+      spans <- traverse captureSpan =<< readIORef spansRef+      case spans of+        [sp] ->+          case lookupAttribute (csAttributes sp) "keiro.retry.attempt" of+            Just (AttributeValue (IntAttribute n)) -> n `shouldBe` 2+            other -> expectationFailure ("expected retry attempt attribute 2, got " <> show other)+        other -> expectationFailure ("expected one span, got " <> show (length other))++    it "counts duplicate deterministic command events" $ \storeHandle -> do+      (exporter, metricsRef) <- inMemoryMetricExporter+      (provider, _env) <-+        createMeterProvider+          emptyMaterializedResources+          defaultSdkMeterProviderOptions {metricExporter = Just exporter}+      meter <- getMeter provider Telemetry.keiroInstrumentationLibrary+      keiroMetrics <- Telemetry.newKeiroMetrics meter+      let supplied = EventId sampleUuid3+          first = stream "counter-command-duplicate-a" :: Stream CounterEventStream+          second = stream "counter-command-duplicate-b" :: Stream CounterEventStream+          options =+            defaultRunCommandOptions+              & #eventIds+              .~ [supplied]+              & #metrics+              ?~ keiroMetrics+      Right (Right _) <-+        Store.runStoreIO storeHandle $+          runCommand options counterEventStream first (Add 1)+      result <-+        Store.runStoreIO storeHandle $+          runCommand options counterEventStream second (Add 2)+      case result of+        Right (Left (StoreFailed Store.DuplicateEvent {})) -> pure ()+        other -> expectationFailure ("expected duplicate event failure, got " <> show other)+      _ <- forceFlushMeterProvider provider Nothing+      exported <- readIORef metricsRef+      lookup "keiro.command.duplicates" (flattenScalarPoints exported) `shouldBe` Just (IntNumber 1)++    it "fails fast when a soft-deleted stream causes a conflict fixpoint" $ \storeHandle -> do+      (exporter, metricsRef) <- inMemoryMetricExporter+      (provider, _env) <-+        createMeterProvider+          emptyMaterializedResources+          defaultSdkMeterProviderOptions {metricExporter = Just exporter}+      meter <- getMeter provider Telemetry.keiroInstrumentationLibrary+      keiroMetrics <- Telemetry.newKeiroMetrics meter+      let target = stream "counter-command-soft-deleted" :: Stream CounterEventStream+          options =+            defaultRunCommandOptions+              & #retryBackoffMicros+              .~ 0+              & #metrics+              ?~ keiroMetrics+      Right (Right _) <-+        Store.runStoreIO storeHandle $+          runCommand options counterEventStream target (Add 1)+      Right (Just _) <-+        Store.runStoreIO storeHandle $+          Store.softDeleteStream (StreamName "counter-command-soft-deleted")+      result <-+        Store.runStoreIO storeHandle $+          runCommand options counterEventStream target (Add 2)+      case result of+        Right (Left (ConflictFixpoint (StreamVersion 0) Store.StreamAlreadyExists {})) -> pure ()+        other -> expectationFailure ("expected conflict fixpoint, got " <> show other)+      _ <- forceFlushMeterProvider provider Nothing+      exported <- readIORef metricsRef+      lookup "keiro.command.conflicts" (flattenScalarPoints exported) `shouldBe` Just (IntNumber 1)++    it "surfaces decode failure during hydration" $ \storeHandle -> do+      Right _ <-+        Store.runStoreIO storeHandle $+          Store.appendToStream+            (StreamName "counter-command-decode-failure")+            NoStream+            [ EventData+                { eventId = Nothing,+                  eventType = EventType "OtherEvent",+                  payload = object [],+                  metadata = Just (metadataForOrDie 1 Nothing),+                  causationId = Nothing,+                  correlationId = Nothing+                }+            ]+      let target = stream "counter-command-decode-failure" :: Stream CounterEventStream+      result <-+        Store.runStoreIO storeHandle $+          runCommand defaultRunCommandOptions counterEventStream target (Add 1)+      result+        `shouldBe` Right+          (Left (HydrationDecodeFailed (UnknownEventType (EventType "OtherEvent") [EventType "CounterAdded", EventType "CounterAudited"])))++    it "surfaces a typed no-inverting-edge hydration failure" $ \storeHandle -> do+      let targetStreamName = StreamName "counter-command-no-inverting-edge"+          target = stream "counter-command-no-inverting-edge" :: Stream CounterEventStream+      appendCounterEvents storeHandle targetStreamName [CounterAudited 7]+      result <-+        Store.runStoreIO storeHandle $+          runCommand defaultRunCommandOptions counterEventStream target (Add 1)+      result+        `shouldBe` Right+          (Left (HydrationReplayFailed (StreamVersion 1) HydrationNoInvertingEdge))++    it "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)++    it "reads the minimum checkpoint across consumer-group subscription members" $ \storeHandle -> do+      Right () <-+        Store.runStoreIO storeHandle $+          Store.runTransaction $ do+            Tx.statement ("counter-read-model-sub", 1, 7) upsertSubscriptionCursorMemberStmt+            Tx.statement ("counter-read-model-sub", 2, 3) upsertSubscriptionCursorMemberStmt+      position <-+        Store.runStoreIO storeHandle $+          readSubscriptionPosition "counter-read-model-sub"+      position `shouldBe` Right (Just (GlobalPosition 3))++    it "Strong returns immediately on an empty log" $ \storeHandle -> do+      Right () <-+        Store.runStoreIO storeHandle $+          initializeRegisteredReadModel counterReadModel initializeCounterReadModelTable+      queryResult <-+        Store.runStoreIO storeHandle $+          runQueryWith Nothing Strong counterReadModel "empty"+      queryResult `shouldBe` Right (Right 0)++    it "Strong returns immediately when the subscription is already at the store head" $ \_ ->+      withFreshResourceStore fixture $ \(storeHandle, StoreRunner runner) -> do+        Right () <-+          Store.runStoreIO storeHandle $+            initializeRegisteredReadModel counterReadModel initializeCounterReadModelTable+        let target = stream "read-model-strong-at-head" :: Stream CounterEventStream+        Right (Right commandResult) <-+          runner $+            runCommandWithProjections+              defaultRunCommandOptions+              counterEventStream+              target+              (Add 5)+              [counterInlineProjection]+        globalPosition <- case commandResult ^. #globalPosition of+          Just position -> pure position+          Nothing -> expectationFailure "expected command global position" *> error "unreachable"+        Right () <-+          Store.runStoreIO storeHandle $+            Store.runTransaction $+              Tx.statement ("counter-read-model-sub", globalPositionToInt globalPosition) upsertSubscriptionCursorStmt+        queryResult <-+          Store.runStoreIO storeHandle $+            runQueryWith Nothing Strong counterReadModel "inline"+        queryResult `shouldBe` Right (Right 5)++    it "Strong blocks until the subscription reaches the store head captured at query start" $ \_ ->+      withFreshResourceStore fixture $ \(storeHandle, StoreRunner runner) -> do+        Right () <-+          Store.runStoreIO storeHandle $+            initializeRegisteredReadModel counterReadModel initializeCounterReadModelTable+        let target = stream "read-model-strong-blocking" :: Stream CounterEventStream+        Right (Right commandResult) <-+          runner $+            runCommandWithProjections+              defaultRunCommandOptions+              counterEventStream+              target+              (Add 6)+              [counterInlineProjection]+        globalPosition <- case commandResult ^. #globalPosition of+          Just position -> pure position+          Nothing -> expectationFailure "expected command global position" *> error "unreachable"+        _ <- forkIO $ do+          threadDelay 20000+          advanced <-+            Store.runStoreIO storeHandle $+              Store.runTransaction $+                Tx.statement ("counter-read-model-sub", globalPositionToInt globalPosition) upsertSubscriptionCursorStmt+          case advanced of+            Right () -> pure ()+            Left err -> expectationFailure ("failed to advance subscription cursor: " <> show err)+        queryResult <-+          Store.runStoreIO storeHandle $+            runQueryWith Nothing Strong counterReadModel "inline"+        queryResult `shouldBe` Right (Right 6)++    it "Strong returns when its category is caught up despite another active category" $ \_ ->+      withFreshResourceStore fixture $ \(storeHandle, StoreRunner runner) -> do+        Right () <-+          Store.runStoreIO storeHandle $+            initializeRegisteredReadModel counterReadModel initializeCounterReadModelTable+        let counterTarget = stream "counter-strong-scope" :: Stream CounterEventStream+            otherTarget = stream "otherload-1" :: Stream CounterEventStream+        Right (Right counterResult) <-+          runner $+            runCommandWithProjections+              defaultRunCommandOptions+              counterEventStream+              counterTarget+              (Add 8)+              [counterInlineProjection]+        counterPosition <- case counterResult ^. #globalPosition of+          Just position -> pure position+          Nothing -> expectationFailure "expected counter global position" *> error "unreachable"+        Right () <-+          Store.runStoreIO storeHandle $+            Store.runTransaction $+              Tx.statement+                ("counter-read-model-sub", globalPositionToInt counterPosition)+                upsertSubscriptionCursorStmt+        Right (Right _) <-+          Store.runStoreIO storeHandle $+            runCommand defaultRunCommandOptions counterEventStream otherTarget (Add 1)+        queryResult <-+          Store.runStoreIO storeHandle $+            runQueryWith Nothing Strong counterCategoryReadModel "inline"+        queryResult `shouldBe` Right (Right 8)++    it "inline projection populates actor and source_event_id from command metadata" $ \_ ->+      withFreshResourceStore fixture $ \(storeHandle, StoreRunner runner) -> do+        Right () <-+          Store.runStoreIO storeHandle $+            initializeRegisteredReadModel counterReadModel initializeCounterReadModelTable+        let target = stream "read-model-inline-metadata" :: Stream CounterEventStream+            opts =+              defaultRunCommandOptions+                & #metadata+                ?~ object ["actor" Aeson..= ("agent-7" :: Text)]+        Right (Right _) <-+          runner $+            runCommandWithProjections opts counterEventStream target (Add 5) [counterInlineProjection]+        Right row <-+          Store.runStoreIO storeHandle $+            Store.runTransaction (Tx.statement "inline" selectCounterMetaStmt)+        -- selectCounterMetaStmt returns (amount, actor, source_event_id).+        row `shouldSatisfy` \(amount, actor, srcId) ->+          amount == 5 && actor == Just "agent-7" && isJust srcId++    it "waits for async projection cursor with PositionWait" $ \_ ->+      withFreshResourceStore fixture $ \(storeHandle, StoreRunner runner) -> do+        Right () <-+          Store.runStoreIO storeHandle $+            initializeRegisteredReadModel counterReadModel initializeCounterReadModelTable+        let target = stream "read-model-position-wait" :: Stream CounterEventStream+        Right (Right commandResult) <-+          runner $+            runCommandWithProjections+              defaultRunCommandOptions+              counterEventStream+              target+              (Add 3)+              [counterInlineProjection]+        globalPosition <- case commandResult ^. #globalPosition of+          Just position -> pure position+          Nothing -> expectationFailure "expected command global position" *> error "unreachable"+        Right () <-+          Store.runStoreIO storeHandle $+            Store.runTransaction $+              Tx.statement ("counter-read-model-sub", globalPositionToInt globalPosition) upsertSubscriptionCursorStmt+        queryResult <-+          Store.runStoreIO storeHandle $+            runQueryWith+              Nothing+              (PositionWait (fastWaitOptions & #target .~ Just globalPosition))+              counterReadModel+              "inline"+        queryResult `shouldBe` Right (Right 3)++    it "times out when PositionWait target is not reached" $ \storeHandle -> do+      Right () <-+        Store.runStoreIO storeHandle $+          initializeRegisteredReadModel counterReadModel initializeCounterReadModelTable+      Right () <-+        Store.runStoreIO storeHandle $+          Store.runTransaction $+            Tx.statement ("counter-read-model-sub", 1) upsertSubscriptionCursorStmt+      queryResult <-+        Store.runStoreIO storeHandle $+          runQueryWith+            Nothing+            (PositionWait (fastWaitOptions & #target .~ Just (GlobalPosition 5)))+            counterReadModel+            "timeout"+      queryResult+        `shouldBe` Right+          (Left (ReadModelWaitTimeout "counter-read-model" (GlobalPosition 5) (GlobalPosition 1)))++    it "does not write the registry row on repeated read-model queries" $ \storeHandle -> do+      Right () <-+        Store.runStoreIO storeHandle $+          initializeRegisteredReadModel counterReadModel initializeCounterReadModelTable+      Right (Right 0) <-+        Store.runStoreIO storeHandle $+          runQuery Nothing counterReadModel "no-churn"+      Right xminBefore <-+        Store.runStoreIO storeHandle $+          Store.runTransaction $+            Tx.statement "counter-read-model" readModelXminStmt+      Right (Right 0) <-+        Store.runStoreIO storeHandle $+          runQuery Nothing counterReadModel "no-churn"+      Right xminAfter <-+        Store.runStoreIO storeHandle $+          Store.runTransaction $+            Tx.statement "counter-read-model" readModelXminStmt+      xminAfter `shouldBe` xminBefore++    it "rejects an unregistered model without creating a registry row" $ \storeHandle -> do+      let unregistered :: ReadModel Text Int+          unregistered = counterReadModel & #name .~ ("never-registered" :: Text)+      queryResult <-+        Store.runStoreIO storeHandle $+          runQuery Nothing unregistered "missing"+      queryResult `shouldBe` Right (Left (ReadModelUnregistered "never-registered"))+      found <-+        Store.runStoreIO storeHandle $+          lookupReadModel "never-registered"+      found `shouldBe` Right Nothing++    it "handles concurrent explicit read-model registration" $ \storeHandle -> do+      Right () <-+        Store.runStoreIO storeHandle $+          Store.runTransaction initializeCounterReadModelTable+      resultA <- newEmptyMVar+      resultB <- newEmptyMVar+      _ <-+        forkIO $+          Store.runStoreIO storeHandle (registerReadModelDefinition counterReadModel)+            >>= putMVar resultA+      _ <-+        forkIO $+          Store.runStoreIO storeHandle (registerReadModelDefinition counterReadModel)+            >>= putMVar resultB+      first <- takeMVar resultA+      second <- takeMVar resultB+      first `shouldBe` Right ()+      second `shouldBe` Right ()+      queryResult <-+        Store.runStoreIO storeHandle $+          runQuery Nothing counterReadModel "concurrent"+      queryResult `shouldBe` Right (Right 0)++    it "rejects stale read-model schema" $ \storeHandle -> do+      Right () <-+        Store.runStoreIO storeHandle $+          initializeRegisteredReadModel counterReadModel initializeCounterReadModelTable+      Right (Right 0) <-+        Store.runStoreIO storeHandle $+          runQuery Nothing counterReadModel "stale"+      Right () <-+        Store.runStoreIO storeHandle $+          Store.runTransaction $+            Tx.statement ("counter-read-model", 99) updateReadModelVersionStmt+      queryResult <-+        Store.runStoreIO storeHandle $+          runQuery Nothing counterReadModel "stale"+      queryResult+        `shouldBe` Right+          (Left (ReadModelStaleSchema "counter-read-model" 1 99 "counter-read-model-v1" "counter-read-model-v1"))++    it "surfaces unknown read-model statuses with the raw status text" $ \storeHandle -> do+      Right () <-+        Store.runStoreIO storeHandle $+          initializeRegisteredReadModel counterReadModel initializeCounterReadModelTable+      Right (Right 0) <-+        Store.runStoreIO storeHandle $+          runQuery Nothing counterReadModel "unknown-status"+      Right () <-+        Store.runStoreIO storeHandle $+          Store.runTransaction $+            Tx.statement ("counter-read-model", "wedged") updateReadModelStatusStmt+      queryResult <-+        Store.runStoreIO storeHandle $+          runQuery Nothing counterReadModel "unknown-status"+      queryResult+        `shouldBe` Right+          (Left (ReadModelNotLive "counter-read-model" (UnknownStatus "wedged")))++    it "ignores duplicate async event by source_event_id" $ \storeHandle -> do+      Right () <-+        Store.runStoreIO storeHandle $+          initializeRegisteredReadModel counterReadModel initializeCounterReadModelTable+      let target = stream "read-model-async-idempotent" :: Stream CounterEventStream+      Right (Right _) <-+        Store.runStoreIO storeHandle $+          runCommand defaultRunCommandOptions counterEventStream target (Add 7)+      Right recorded <-+        Store.runStoreIO storeHandle $+          Store.readStreamForward (StreamName "read-model-async-idempotent") (StreamVersion 0) 10+      event <- case Vector.toList recorded of+        [onlyEvent] -> pure onlyEvent+        other -> expectationFailure ("expected one event, got " <> show other) *> error "unreachable"+      Right outcomes <- Store.runStoreIO storeHandle $+        Store.runTransaction $ do+          first <- applyAsyncProjection counterAsyncProjection event+          second <- applyAsyncProjection counterAsyncProjection event+          pure (first, second)+      outcomes `shouldBe` (AsyncApplied, AsyncDuplicate)+      queryResult <-+        Store.runStoreIO storeHandle $+          runQuery Nothing counterReadModel "async-idempotent"+      queryResult `shouldBe` Right (Right 7)++    it "deduplicates async projection application across transactions and reopens after pruning" $ \storeHandle -> do+      Right () <-+        Store.runStoreIO storeHandle $+          Store.runTransaction initializeProjectionDedupCounterTable+      Right _ <-+        Store.runStoreIO storeHandle $+          registerReadModel "projection-dedup-counter-model" 1 "projection-dedup-counter-v1"+      let target = stream "read-model-async-dedup-window" :: Stream CounterEventStream+      Right (Right _) <-+        Store.runStoreIO storeHandle $+          runCommand defaultRunCommandOptions counterEventStream target (Add 7)+      Right recorded <-+        Store.runStoreIO storeHandle $+          Store.readStreamForward (StreamName "read-model-async-dedup-window") (StreamVersion 0) 10+      event <- case Vector.toList recorded of+        [onlyEvent] -> pure onlyEvent+        other -> expectationFailure ("expected one event, got " <> show other) *> error "unreachable"+      let incrementingProjection =+            AsyncProjection+              { name = "incrementing-async-projection",+                readModelName = "projection-dedup-counter-model",+                subscriptionName = "incrementing-async-projection-sub",+                applyRecorded = \_ -> Tx.statement () incrementProjectionDedupCounterStmt,+                idempotencyKey = \recordedEvent -> recordedEvent ^. #eventId+              }+      Right AsyncApplied <-+        Store.runStoreIO storeHandle $+          Store.runTransaction $+            applyAsyncProjection incrementingProjection event+      Right AsyncDuplicate <-+        Store.runStoreIO storeHandle $+          Store.runTransaction $+            applyAsyncProjection incrementingProjection event+      Right countAfterDuplicate <-+        Store.runStoreIO storeHandle $+          Store.runTransaction $+            Tx.statement () selectProjectionDedupCounterStmt+      countAfterDuplicate `shouldBe` 1+      cutoff <- addUTCTime 1 <$> getCurrentTime+      pruned <- Store.runStoreIO storeHandle $ pruneAsyncProjectionDedupBefore cutoff+      pruned `shouldBe` Right 1+      Right AsyncApplied <-+        Store.runStoreIO storeHandle $+          Store.runTransaction $+            applyAsyncProjection incrementingProjection event+      Right countAfterPrune <-+        Store.runStoreIO storeHandle $+          Store.runTransaction $+            Tx.statement () selectProjectionDedupCounterStmt+      countAfterPrune `shouldBe` 2++    it "rebuild repopulates the projection table through the supported workflow" $ \storeHandle -> do+      Right () <-+        Store.runStoreIO storeHandle $+          initializeRegisteredReadModel counterReadModel initializeCounterReadModelTable+      let target = stream "read-model-rebuild-runbook" :: Stream CounterEventStream+      Right (Right _) <-+        Store.runStoreIO storeHandle $+          runCommand defaultRunCommandOptions counterEventStream target (Add 7)+      Right recorded <-+        Store.runStoreIO storeHandle $+          Store.readStreamForward (StreamName "read-model-rebuild-runbook") (StreamVersion 0) 10+      event <- case Vector.toList recorded of+        [onlyEvent] -> pure onlyEvent+        other -> expectationFailure ("expected one event, got " <> show other) *> error "unreachable"+      Right AsyncApplied <-+        Store.runStoreIO storeHandle $+          Store.runTransaction $+            applyAsyncProjection counterAsyncProjection event+      Right () <-+        Store.runStoreIO storeHandle $+          Store.runTransaction $+            Tx.statement+              ( "counter-read-model-sub",+                globalPositionToInt (event ^. #globalPosition)+              )+              upsertSubscriptionCursorStmt+      beforeRebuild <-+        Store.runStoreIO storeHandle $+          runQuery Nothing counterReadModel "async-idempotent"+      beforeRebuild `shouldBe` Right (Right 7)++      Right rebuilding <-+        Store.runStoreIO storeHandle $+          Rebuild.startRebuild+            counterReadModel+            [counterAsyncProjection ^. #name]+            (GlobalPosition 0)+      rebuilding ^. #status `shouldBe` Rebuilding+      checkpointAfterReset <-+        Store.runStoreIO storeHandle $+          readSubscriptionPosition "counter-read-model-sub"+      checkpointAfterReset `shouldBe` Right (Just (GlobalPosition 0))+      Right AsyncApplied <-+        Store.runStoreIO storeHandle $+          Store.runTransaction $+            applyAsyncProjectionUnfenced counterAsyncProjection event+      Right (Right live) <-+        Store.runStoreIO storeHandle $+          Rebuild.finishRebuild+            counterReadModel+            [counterAsyncProjection ^. #name]+            (GlobalPosition 0)+      live ^. #status `shouldBe` Live++      afterRebuild <-+        Store.runStoreIO storeHandle $+          runQuery Nothing counterReadModel "async-idempotent"+      afterRebuild `shouldBe` Right (Right 7)++    it "keeps a non-empty-log rebuild offline when replay applies nothing" $ \storeHandle -> do+      Right () <-+        Store.runStoreIO storeHandle $+          initializeRegisteredReadModel counterReadModel initializeCounterReadModelTable+      let target = stream "read-model-rebuild-empty-replay" :: Stream CounterEventStream+      Right (Right _) <-+        Store.runStoreIO storeHandle $+          runCommand defaultRunCommandOptions counterEventStream target (Add 7)+      Right _ <-+        Store.runStoreIO storeHandle $+          Rebuild.startRebuild+            counterReadModel+            [counterAsyncProjection ^. #name]+            (GlobalPosition 0)+      finishResult <-+        Store.runStoreIO storeHandle $+          Rebuild.finishRebuild+            counterReadModel+            [counterAsyncProjection ^. #name]+            (GlobalPosition 0)+      case finishResult of+        Right (Left (Rebuild.RebuildProducedNoApplies modelName headPosition)) -> do+          modelName `shouldBe` "counter-read-model"+          headPosition `shouldSatisfy` (> GlobalPosition 0)+        other -> expectationFailure ("expected zero-apply guard, got " <> show other)+      queryResult <-+        Store.runStoreIO storeHandle $+          runQuery Nothing counterReadModel "async-idempotent"+      queryResult+        `shouldBe` Right+          (Left (ReadModelNotLive "counter-read-model" Rebuilding))++    it "fences live async application while a model is rebuilding" $ \storeHandle -> do+      Right () <-+        Store.runStoreIO storeHandle $+          initializeRegisteredReadModel counterReadModel initializeCounterReadModelTable+      let target = stream "read-model-fenced-apply" :: Stream CounterEventStream+      Right (Right _) <-+        Store.runStoreIO storeHandle $+          runCommand defaultRunCommandOptions counterEventStream target (Add 7)+      Right recorded <-+        Store.runStoreIO storeHandle $+          Store.readStreamForward (StreamName "read-model-fenced-apply") (StreamVersion 0) 10+      event <- case Vector.toList recorded of+        [onlyEvent] -> pure onlyEvent+        other -> expectationFailure ("expected one event, got " <> show other) *> error "unreachable"+      Right _ <-+        Store.runStoreIO storeHandle $+          Rebuild.startRebuild+            counterReadModel+            [counterAsyncProjection ^. #name]+            (GlobalPosition 0)+      outcome <-+        Store.runStoreIO storeHandle $+          Store.runTransaction $+            applyAsyncProjection counterAsyncProjection event+      outcome `shouldBe` Right AsyncFenced+      Right dedupCount <-+        Store.runStoreIO storeHandle $+          Store.runTransaction $+            Tx.statement (counterAsyncProjection ^. #name) projectionDedupCountStmt+      dedupCount `shouldBe` 0+      Right amount <-+        Store.runStoreIO storeHandle $+          Store.runTransaction $+            Tx.statement "async-idempotent" selectCounterReadModelStmt+      amount `shouldBe` 0++    it "keeps a live applier out of the rebuild window and reopens it after promotion" $ \storeHandle -> do+      Right () <-+        Store.runStoreIO storeHandle $+          initializeRegisteredReadModel counterReadModel initializeCounterReadModelTable+      let target = stream "read-model-fence-race" :: Stream CounterEventStream+      Right (Right _) <-+        Store.runStoreIO storeHandle $+          runCommand defaultRunCommandOptions counterEventStream target (Add 7)+      Right recorded <-+        Store.runStoreIO storeHandle $+          Store.readStreamForward (StreamName "read-model-fence-race") (StreamVersion 0) 10+      event <- case Vector.toList recorded of+        [onlyEvent] -> pure onlyEvent+        other -> expectationFailure ("expected one event, got " <> show other) *> error "unreachable"+      enterRebuildWindow <- newEmptyMVar+      liveApplyResult <- newEmptyMVar+      _ <-+        forkIO $ do+          takeMVar enterRebuildWindow+          Store.runStoreIO+            storeHandle+            (Store.runTransaction (applyAsyncProjection counterAsyncProjection event))+            >>= putMVar liveApplyResult+      Right _ <-+        Store.runStoreIO storeHandle $+          Rebuild.startRebuild+            counterReadModel+            [counterAsyncProjection ^. #name]+            (GlobalPosition 0)+      putMVar enterRebuildWindow ()+      takeMVar liveApplyResult `shouldReturn` Right AsyncFenced++      Right AsyncApplied <-+        Store.runStoreIO storeHandle $+          Store.runTransaction $+            applyAsyncProjectionUnfenced counterAsyncProjection event+      Right (Right _) <-+        Store.runStoreIO storeHandle $+          Rebuild.finishRebuild+            counterReadModel+            [counterAsyncProjection ^. #name]+            (GlobalPosition 0)+      cutoff <- addUTCTime 1 <$> getCurrentTime+      pruned <- Store.runStoreIO storeHandle $ pruneAsyncProjectionDedupBefore cutoff+      pruned `shouldBe` Right 1+      reapplied <-+        Store.runStoreIO storeHandle $+          Store.runTransaction $+            applyAsyncProjection counterAsyncProjection event+      reapplied `shouldBe` Right AsyncApplied+      queryResult <-+        Store.runStoreIO storeHandle $+          runQuery Nothing counterReadModel "async-idempotent"+      queryResult `shouldBe` Right (Right 7)++    it "tracks rebuild state transitions" $ \storeHandle -> do+      Right () <-+        Store.runStoreIO storeHandle $+          registerReadModelDefinition counterReadModel+      Right rebuilding <-+        Store.runStoreIO storeHandle $+          Rebuild.rebuild counterReadModel+      rebuilding ^. #status `shouldBe` Rebuilding+      Right live <-+        Store.runStoreIO storeHandle $+          Rebuild.promote counterReadModel+      live ^. #status `shouldBe` Live+      Right abandoned <-+        Store.runStoreIO storeHandle $+          Rebuild.abandonRebuild counterReadModel+      abandoned ^. #status `shouldBe` Abandoned++    it "records projection lag behind the log head" $ \storeHandle -> do+      (exporter, metricsRef) <- inMemoryMetricExporter+      (provider, _env) <-+        createMeterProvider+          emptyMaterializedResources+          defaultSdkMeterProviderOptions {metricExporter = Just exporter}+      meter <- getMeter provider Telemetry.keiroInstrumentationLibrary+      keiroMetrics <- Telemetry.newKeiroMetrics meter+      Right () <-+        Store.runStoreIO storeHandle $+          initializeRegisteredReadModel counterReadModel initializeCounterReadModelTable+      let target = stream "read-model-lag" :: Stream CounterEventStream+      Right (Right _) <-+        Store.runStoreIO storeHandle $+          runCommand defaultRunCommandOptions counterEventStream target (Add 1)+      Right (Right _) <-+        Store.runStoreIO storeHandle $+          runCommand defaultRunCommandOptions counterEventStream target (Add 1)+      -- The subscription cursor is never advanced, so the read model is behind+      -- the head by every appended event: the lag gauge records that gap.+      Right () <-+        Store.runStoreIO storeHandle $+          recordProjectionLag (Just keiroMetrics) counterAsyncProjection+      _ <- forceFlushMeterProvider provider Nothing+      exported <- readIORef metricsRef+      let scalars = flattenScalarPoints exported+      case lookup "keiro.projection.lag" scalars of+        Just (IntNumber n) -> n `shouldSatisfy` (>= 1)+        other -> expectationFailure ("expected an integer projection lag, got " <> show other)++    it "counts a position-wait timeout in the timeout counter" $ \storeHandle -> do+      (exporter, metricsRef) <- inMemoryMetricExporter+      (provider, _env) <-+        createMeterProvider+          emptyMaterializedResources+          defaultSdkMeterProviderOptions {metricExporter = Just exporter}+      meter <- getMeter provider Telemetry.keiroInstrumentationLibrary+      keiroMetrics <- Telemetry.newKeiroMetrics meter+      Right () <-+        Store.runStoreIO storeHandle $+          initializeRegisteredReadModel counterReadModel initializeCounterReadModelTable+      Right () <-+        Store.runStoreIO storeHandle $+          Store.runTransaction $+            Tx.statement ("counter-read-model-sub", 1) upsertSubscriptionCursorStmt+      queryResult <-+        Store.runStoreIO storeHandle $+          runQueryWith+            (Just keiroMetrics)+            (PositionWait (fastWaitOptions & #target .~ Just (GlobalPosition 5)))+            counterReadModel+            "timeout"+      queryResult+        `shouldBe` Right+          (Left (ReadModelWaitTimeout "counter-read-model" (GlobalPosition 5) (GlobalPosition 1)))+      _ <- forceFlushMeterProvider provider Nothing+      exported <- readIORef metricsRef+      let scalars = flattenScalarPoints exported+      -- The single give-up bumped the counter exactly once.+      lookup "keiro.projection.wait.timeouts" scalars `shouldBe` Just (IntNumber 1)++  describe "Keiro.ProcessManager" $ around (withFreshResourceStore fixture) $ do+    it "advances manager state, emits a deterministic target command once, and schedules a timer" $ \(_storeHandle, StoreRunner _runner) -> do+      let sourceEvent = recordedFromEventId (EventId sampleUuid) (CounterAdded 9)+      result <-+        _runner $+          runProcessManagerOnce defaultRunCommandOptions counterProcessManager sourceEvent (CounterAdded 9)+      case result of+        Right (Right pmResult) -> do+          case pmResult ^. #managerResult of+            PMStateAppended managerResult ->+              managerResult ^. #streamVersion `shouldBe` StreamVersion 1+            other -> expectationFailure ("expected appended manager state, got " <> show other)+          case pmResult ^. #commandResults of+            [PMCommandAppended commandResult] ->+              commandResult ^. #eventsAppended `shouldBe` 1+            other -> expectationFailure ("expected one emitted command, got " <> show other)+          pmResult ^. #timersScheduled `shouldBe` 1+        other -> expectationFailure ("expected process-manager success, got " <> show other)+      Right managerEvents <-+        _runner $+          Store.readStreamForward (StreamName "pm:counter-order-1") (StreamVersion 0) 10+      Right targetEvents <-+        _runner $+          Store.readStreamForward (StreamName "counter-target-order-1") (StreamVersion 0) 10+      Vector.length managerEvents `shouldBe` 1+      Vector.length targetEvents `shouldBe` 1+      timer <-+        _runner $+          claimDueTimer dueTimerTime+      case timer of+        Right (Just row) -> do+          row ^. #processManagerName `shouldBe` "counter-pm"+          row ^. #correlationId `shouldBe` "order-1"+        other -> expectationFailure ("expected scheduled timer row, got " <> show other)++    it "schedules timers when the manager command emits no events" $ \(_storeHandle, StoreRunner _runner) -> do+      let sourceEvent = recordedFromEventId (EventId sampleUuid) (CounterAdded 9)+      result <-+        _runner $+          runProcessManagerOnce defaultRunCommandOptions timerOnlyProcessManager sourceEvent (CounterAdded 9)+      case result of+        Right (Right pmResult) -> do+          case pmResult ^. #managerResult of+            PMStateAppended managerResult -> do+              managerResult ^. #streamVersion `shouldBe` StreamVersion 0+              managerResult ^. #eventsAppended `shouldBe` 0+            other -> expectationFailure ("expected no-op manager state, got " <> show other)+          pmResult ^. #commandResults `shouldBe` []+          pmResult ^. #timersScheduled `shouldBe` 1+        other -> expectationFailure ("expected process-manager success, got " <> show other)+      dueCount <-+        _runner $+          countDueTimers dueTimerTime+      dueCount `shouldBe` Right 1+      timer <-+        _runner $+          claimDueTimer dueTimerTime+      case timer of+        Right (Just row) -> do+          row ^. #processManagerName `shouldBe` "timer-only-pm"+          row ^. #correlationId `shouldBe` "order-1"+        other -> expectationFailure ("expected scheduled timer row, got " <> show other)++    it "treats duplicate input delivery as idempotent state and command dispatch" $ \(_storeHandle, StoreRunner _runner) -> do+      let sourceEvent = recordedFromEventId (EventId sampleUuid2) (CounterAdded 4)+      Right (Right _) <-+        _runner $+          runProcessManagerOnce defaultRunCommandOptions counterProcessManager sourceEvent (CounterAdded 4)+      duplicate <-+        _runner $+          runProcessManagerOnce defaultRunCommandOptions counterProcessManager sourceEvent (CounterAdded 4)+      case duplicate of+        Right (Right pmResult) -> do+          pmResult ^. #managerResult `shouldSatisfy` \case+            PMStateDuplicate {} -> True+            _ -> False+          pmResult ^. #commandResults `shouldSatisfy` \case+            [PMCommandDuplicate {}] -> True+            _ -> False+        other -> expectationFailure ("expected idempotent duplicate handling, got " <> show other)+      Right managerEvents <-+        _runner $+          Store.readStreamForward (StreamName "pm:counter-order-1") (StreamVersion 0) 10+      Right targetEvents <-+        _runner $+          Store.readStreamForward (StreamName "counter-target-order-1") (StreamVersion 0) 10+      Vector.length managerEvents `shouldBe` 1+      Vector.length targetEvents `shouldBe` 1++    it "replays a Kiroku dead letter freshly and deduplicates a second replay" $ \(_storeHandle, StoreRunner _runner) -> do+      let subName = SubscriptionName "counter-pm-replay-fresh"+          replayHandler recorded =+            case decodeRecorded counterCodec recorded of+              Left err -> pure (Left (Text.pack (show err)))+              Right input -> do+                outcome <-+                  runProcessManagerOnce+                    defaultRunCommandOptions+                    counterProcessManager+                    recorded+                    input+                pure $+                  case outcome of+                    Left err -> Left (Text.pack (show err))+                    Right result -> Right (classifyProcessManagerReplay result)+      source <- deadLetterCounterSource _storeHandle subName (CounterAdded 7)+      Right listed <- _runner (listSubscriptionDeadLetters subName 0)+      Vector.length listed `shouldBe` 1++      Right firstPass <-+        _runner $+          replaySubscriptionDeadLetters subName 0 replayHandler+      firstPass+        `shouldBe` [ ReplayOutcome+                       { replayGlobalPosition = source ^. #globalPosition,+                         replayEventId = source ^. #eventId,+                         replayResult = ReplayedFresh+                       }+                   ]+      processManagerReplayCounts _storeHandle `shouldReturn` (1, 1)++      Right secondPass <-+        _runner $+          replaySubscriptionDeadLetters subName 0 replayHandler+      secondPass+        `shouldBe` [ ReplayOutcome+                       { replayGlobalPosition = source ^. #globalPosition,+                         replayEventId = source ^. #eventId,+                         replayResult = ReplayedDuplicate+                       }+                   ]+      processManagerReplayCounts _storeHandle `shouldReturn` (1, 1)+      Right retained <- _runner (listSubscriptionDeadLetters subName 0)+      Vector.length retained `shouldBe` 1++    it "reports an already-processed Kiroku dead letter without appending" $ \(_storeHandle, StoreRunner _runner) -> do+      let subName = SubscriptionName "counter-pm-replay-duplicate"+          replayHandler recorded =+            case decodeRecorded counterCodec recorded of+              Left err -> pure (Left (Text.pack (show err)))+              Right input -> do+                outcome <-+                  runProcessManagerOnce+                    defaultRunCommandOptions+                    counterProcessManager+                    recorded+                    input+                pure $+                  case outcome of+                    Left err -> Left (Text.pack (show err))+                    Right result -> Right (classifyProcessManagerReplay result)+      source <- deadLetterCounterSource _storeHandle subName (CounterAdded 8)+      Right (Right _) <-+        _runner $+          runProcessManagerOnce+            defaultRunCommandOptions+            counterProcessManager+            source+            (CounterAdded 8)+      countsBefore <- processManagerReplayCounts _storeHandle++      Right outcomes <-+        _runner $+          replaySubscriptionDeadLetters subName 0 replayHandler+      outcomes+        `shouldBe` [ ReplayOutcome+                       { replayGlobalPosition = source ^. #globalPosition,+                         replayEventId = source ^. #eventId,+                         replayResult = ReplayedDuplicate+                       }+                   ]+      processManagerReplayCounts _storeHandle `shouldReturn` countsBefore++    it "keeps multiple workflow process managers isolated by configured streams and categories" $ \(_storeHandle, StoreRunner _runner) -> do+      let sourceEvent = recordedFromEventId (EventId sampleUuid) (CounterAdded 6)+          fulfillmentManager =+            workflowProcessManager+              "fulfillment-pm"+              "pm:fulfillment"+              "fulfillment-target-order-1"+          billingManager =+            workflowProcessManager+              "billing-pm"+              "pm:billing"+              "billing-target-order-1"+      fulfillmentResult <-+        _runner $+          runProcessManagerOnce defaultRunCommandOptions fulfillmentManager sourceEvent (CounterAdded 6)+      billingResult <-+        _runner $+          runProcessManagerOnce defaultRunCommandOptions billingManager sourceEvent (CounterAdded 6)+      assertWorkflowProcessManagerAppended fulfillmentResult+      assertWorkflowProcessManagerAppended billingResult++      Right fulfillmentManagerEvents <-+        _runner $+          Store.readStreamForward (StreamName "pm:fulfillment-order-1") (StreamVersion 0) 10+      Right billingManagerEvents <-+        _runner $+          Store.readStreamForward (StreamName "pm:billing-order-1") (StreamVersion 0) 10+      Right fulfillmentTargetEvents <-+        _runner $+          Store.readStreamForward (StreamName "fulfillment-target-order-1") (StreamVersion 0) 10+      Right billingTargetEvents <-+        _runner $+          Store.readStreamForward (StreamName "billing-target-order-1") (StreamVersion 0) 10+      Vector.length fulfillmentManagerEvents `shouldBe` 1+      Vector.length billingManagerEvents `shouldBe` 1+      Vector.length fulfillmentTargetEvents `shouldBe` 1+      Vector.length billingTargetEvents `shouldBe` 1++      Right fulfillmentCategoryEvents <-+        _runner $+          Store.readCategory (CategoryName "pm:fulfillment") (GlobalPosition 0) 10+      Right billingCategoryEvents <-+        _runner $+          Store.readCategory (CategoryName "pm:billing") (GlobalPosition 0) 10+      Right sharedPmCategoryEvents <-+        _runner $+          Store.readCategory (CategoryName "pm") (GlobalPosition 0) 10+      Right sharedPmNamespaceEvents <-+        _runner $+          Store.readCategory (CategoryName "pm:") (GlobalPosition 0) 10+      Vector.length fulfillmentCategoryEvents `shouldBe` 1+      Vector.length billingCategoryEvents `shouldBe` 1+      sharedPmCategoryEvents `shouldBe` Vector.empty+      sharedPmNamespaceEvents `shouldBe` Vector.empty++    it "worker finalizes AckOk through the ack handle on success" $ \(_storeHandle, StoreRunner _runner) -> do+      decisionsRef <- newIORef []+      let sourceEvent = recordedFromEventId (EventId sampleUuid) (CounterAdded 9)+          messages = [(sourceEvent, CounterAdded 9)]+          adapter = inMemoryAdapter decisionsRef messages+      Right () <-+        _runner $+          runProcessManagerWorker defaultRunCommandOptions counterProcessManager adapter Just+      decisions <- readIORef decisionsRef+      decisions `shouldBe` [AckOk]++    it "worker halts instead of acking when a target dispatch is rejected" $ \(_storeHandle, StoreRunner _runner) -> do+      decisionsRef <- newIORef []+      let sourceEvent = recordedFromEventId (EventId sampleUuid) (CounterAdded 9)+          messages = [(sourceEvent, CounterAdded 9)]+          adapter = inMemoryAdapter decisionsRef messages+          rejectingPm =+            (counterProcessManager :: ProcessManager CounterEvent (HsPred '[] CounterCommand) '[] CounterState CounterCommand CounterEvent (HsPred '[] CounterCommand) '[] CounterState CounterCommand CounterEvent)+              { targetEventStream = rejectingEventStream+              }+      Right () <-+        _runner $+          runProcessManagerWorker defaultRunCommandOptions rejectingPm adapter Just+      decisions <- readIORef decisionsRef+      decisions `shouldSatisfy` \case+        [AckHalt (HaltFatal _)] -> True+        _ -> False+      Right targetEvents <-+        _runner $+          Store.readStreamForward (StreamName "counter-target-order-1") (StreamVersion 0) 10+      Right managerEvents <-+        _runner $+          Store.readStreamForward (StreamName "pm:counter-order-1") (StreamVersion 0) 10+      Vector.length targetEvents `shouldBe` 0+      Vector.length managerEvents `shouldBe` 1++    it "dead-letters a rejected dispatch and continues to the next event" $ \(_storeHandle, StoreRunner _runner) -> do+      (exporter, metricsRef) <- inMemoryMetricExporter+      (provider, _env) <-+        createMeterProvider+          emptyMaterializedResources+          defaultSdkMeterProviderOptions {metricExporter = Just exporter}+      meter <- getMeter provider Telemetry.keiroInstrumentationLibrary+      keiroMetrics <- Telemetry.newKeiroMetrics meter+      decisionsRef <- newIORef []+      let first = recordedFromEventId (EventId sampleUuid) (CounterAdded 9)+          second = recordedFromEventId (EventId sampleUuid2) (CounterAdded 1)+          messages = [(first, CounterAdded 9), (second, CounterAdded 1)]+          adapter = inMemoryAdapter decisionsRef messages+          policyPm =+            (counterProcessManager :: ProcessManager CounterEvent (HsPred '[] CounterCommand) '[] CounterState CounterCommand CounterEvent (HsPred '[] CounterCommand) '[] CounterState CounterCommand CounterEvent)+              { targetEventStream = rejectNineEventStream+              }+          workerOptions =+            defaultWorkerOptions+              & #rejectedCommandPolicy+              .~ RejectedDeadLetter+              & #metrics+              ?~ keiroMetrics+      Right () <-+        _runner $+          runProcessManagerWorkerWith workerOptions defaultRunCommandOptions policyPm adapter Just+      readIORef decisionsRef `shouldReturn` [AckOk, AckOk]+      Right deadLetters <- _runner (listDispatchDeadLetters "counter-pm")+      case deadLetters of+        [row] -> do+          row ^. #dispatcherKind `shouldBe` DispatcherProcessManager+          row ^. #correlationId `shouldBe` "order-1"+          row ^. #sourceEventId `shouldBe` EventId sampleUuid+          row ^. #emitIndex `shouldBe` 0+          row ^. #targetStreamName `shouldBe` StreamName "counter-target-order-1"+          row ^. #errorClass `shouldBe` "command_rejected"+          row ^. #attemptCount `shouldBe` 1+        other -> expectationFailure ("expected one rejected dispatch dead letter, got " <> show other)+      Right targetEvents <-+        _runner $+          Store.readStreamForward (StreamName "counter-target-order-1") (StreamVersion 0) 10+      Right managerEvents <-+        _runner $+          Store.readStreamForward (StreamName "pm:counter-order-1") (StreamVersion 0) 10+      Vector.length targetEvents `shouldBe` 1+      Vector.length managerEvents `shouldBe` 2+      _ <- forceFlushMeterProvider provider Nothing+      exported <- readIORef metricsRef+      lookup "keiro.dispatch.deadlettered" (flattenScalarPoints exported) `shouldBe` Just (IntNumber 1)++    it "skips a rejected dispatch without writing a dead-letter row" $ \(_storeHandle, StoreRunner _runner) -> do+      (exporter, metricsRef) <- inMemoryMetricExporter+      (provider, _env) <-+        createMeterProvider+          emptyMaterializedResources+          defaultSdkMeterProviderOptions {metricExporter = Just exporter}+      meter <- getMeter provider Telemetry.keiroInstrumentationLibrary+      keiroMetrics <- Telemetry.newKeiroMetrics meter+      decisionsRef <- newIORef []+      let sourceEvent = recordedFromEventId (EventId sampleUuid) (CounterAdded 9)+          adapter = inMemoryAdapter decisionsRef [(sourceEvent, CounterAdded 9)]+          rejectingPm =+            (counterProcessManager :: ProcessManager CounterEvent (HsPred '[] CounterCommand) '[] CounterState CounterCommand CounterEvent (HsPred '[] CounterCommand) '[] CounterState CounterCommand CounterEvent)+              { targetEventStream = rejectingEventStream+              }+          workerOptions =+            defaultWorkerOptions+              & #rejectedCommandPolicy+              .~ RejectedSkip+              & #metrics+              ?~ keiroMetrics+      Right () <-+        _runner $+          runProcessManagerWorkerWith workerOptions defaultRunCommandOptions rejectingPm adapter Just+      readIORef decisionsRef `shouldReturn` [AckOk]+      Right deadLetters <- _runner (listDispatchDeadLetters "counter-pm")+      deadLetters `shouldBe` []+      _ <- forceFlushMeterProvider provider Nothing+      exported <- readIORef metricsRef+      lookup "keiro.dispatch.deadlettered" (flattenScalarPoints exported) `shouldBe` Just (IntNumber 1)++    it "dead-letters a manager-state rejection at emit index minus one" $ \(_storeHandle, StoreRunner _runner) -> do+      decisionsRef <- newIORef []+      let sourceEvent = recordedFromEventId (EventId sampleUuid) (CounterAdded 9)+          adapter = inMemoryAdapter decisionsRef [(sourceEvent, CounterAdded 9)]+          rejectingManager =+            (counterProcessManager :: ProcessManager CounterEvent (HsPred '[] CounterCommand) '[] CounterState CounterCommand CounterEvent (HsPred '[] CounterCommand) '[] CounterState CounterCommand CounterEvent)+              { eventStream = rejectingEventStream+              }+          workerOptions = defaultWorkerOptions & #rejectedCommandPolicy .~ RejectedDeadLetter+      Right () <-+        _runner $+          runProcessManagerWorkerWith workerOptions defaultRunCommandOptions rejectingManager adapter Just+      readIORef decisionsRef `shouldReturn` [AckOk]+      Right deadLetters <- _runner (listDispatchDeadLetters "counter-pm")+      case deadLetters of+        [row] -> do+          row ^. #emitIndex `shouldBe` (-1)+          row ^. #targetStreamName `shouldBe` StreamName "pm:counter-order-1"+          row ^. #errorClass `shouldBe` "command_rejected"+        other -> expectationFailure ("expected one manager-state dead letter, got " <> show other)+      Right managerEvents <-+        _runner $+          Store.readStreamForward (StreamName "pm:counter-order-1") (StreamVersion 0) 10+      managerEvents `shouldBe` Vector.empty++    it "keeps rejected-dispatch dead letters idempotent on source redelivery" $ \(_storeHandle, StoreRunner _runner) -> do+      decisionsRef <- newIORef []+      let sourceEvent = recordedFromEventId (EventId sampleUuid) (CounterAdded 9)+          adapter = inMemoryAdapter decisionsRef [(sourceEvent, CounterAdded 9), (sourceEvent, CounterAdded 9)]+          rejectingPm =+            (counterProcessManager :: ProcessManager CounterEvent (HsPred '[] CounterCommand) '[] CounterState CounterCommand CounterEvent (HsPred '[] CounterCommand) '[] CounterState CounterCommand CounterEvent)+              { targetEventStream = rejectingEventStream+              }+          workerOptions = defaultWorkerOptions & #rejectedCommandPolicy .~ RejectedDeadLetter+      Right () <-+        _runner $+          runProcessManagerWorkerWith workerOptions defaultRunCommandOptions rejectingPm adapter Just+      readIORef decisionsRef `shouldReturn` [AckOk, AckOk]+      Right deadLetters <- _runner (listDispatchDeadLetters "counter-pm")+      Prelude.length deadLetters `shouldBe` 1++    it "records dispatch failures through worker metrics" $ \(_storeHandle, StoreRunner _runner) -> do+      (exporter, metricsRef) <- inMemoryMetricExporter+      (provider, _env) <-+        createMeterProvider+          emptyMaterializedResources+          defaultSdkMeterProviderOptions {metricExporter = Just exporter}+      meter <- getMeter provider Telemetry.keiroInstrumentationLibrary+      keiroMetrics <- Telemetry.newKeiroMetrics meter+      decisionsRef <- newIORef []+      let sourceEvent = recordedFromEventId (EventId sampleUuid) (CounterAdded 9)+          messages = [(sourceEvent, CounterAdded 9)]+          adapter = inMemoryAdapter decisionsRef messages+          rejectingPm =+            (counterProcessManager :: ProcessManager CounterEvent (HsPred '[] CounterCommand) '[] CounterState CounterCommand CounterEvent (HsPred '[] CounterCommand) '[] CounterState CounterCommand CounterEvent)+              { targetEventStream = rejectingEventStream+              }+          workerOptions = defaultWorkerOptions & #metrics ?~ keiroMetrics+      Right () <-+        _runner $+          runProcessManagerWorkerWith workerOptions defaultRunCommandOptions rejectingPm adapter Just+      _ <- forceFlushMeterProvider provider Nothing+      exported <- readIORef metricsRef+      lookup "keiro.dispatch.failed" (flattenScalarPoints exported) `shouldBe` Just (IntNumber 1)++    it "classifies transient store failures as retry and deterministic command failures as halt" $ \(_storeHandle, StoreRunner _runner) -> do+      isRejectionClass CommandRejected `shouldBe` True+      isRejectionClass (CommandAmbiguous [0, 1]) `shouldBe` True+      isRejectionClass (EncodeFailed (NonObjectCallerMetadata Aeson.Null)) `shouldBe` False+      ackForCommandError (RetryDelay 5) (StoreFailed (Store.ConnectionLost "boom"))+        `shouldBe` AckRetry (RetryDelay 5)+      ackForCommandError (RetryDelay 5) CommandRejected `shouldSatisfy` \case+        AckHalt (HaltFatal _) -> True+        _ -> False+      ackForCommandError (RetryDelay 5) (CommandAmbiguous [0, 1]) `shouldSatisfy` \case+        AckHalt (HaltFatal _) -> True+        _ -> False++    it "worker applies poison-message policy on decode failure" $ \(_storeHandle, StoreRunner _runner) -> do+      let badMessages = ["not-decodable" :: Text]+      defaultDecisions <- newIORef []+      Right () <-+        _runner $+          runProcessManagerWorker+            defaultRunCommandOptions+            counterProcessManager+            (inMemoryAdapter defaultDecisions badMessages)+            (const Nothing)+      defaultObserved <- readIORef defaultDecisions+      defaultObserved `shouldSatisfy` \case+        [AckHalt (HaltFatal _)] -> True+        _ -> False++      skippedRef <- newIORef []+      skipDecisions <- newIORef []+      let skipOptions =+            defaultWorkerOptions+              & #poisonPolicy+              .~ PoisonSkip (\env -> liftIO (modifyIORef' skippedRef (<> [env ^. #payload])))+      Right () <-+        _runner $+          runProcessManagerWorkerWith+            skipOptions+            defaultRunCommandOptions+            counterProcessManager+            (inMemoryAdapter skipDecisions badMessages)+            (const Nothing)+      readIORef skipDecisions `shouldReturn` [AckOk]+      readIORef skippedRef `shouldReturn` badMessages++      deadLetterDecisions <- newIORef []+      deadLetterRef <- newIORef []+      let deadLetterOptions =+            defaultWorkerOptions+              & #poisonPolicy+              .~ PoisonDeadLetter (\env -> liftIO (modifyIORef' deadLetterRef (<> [env ^. #payload])))+      Right () <-+        _runner $+          runProcessManagerWorkerWith+            deadLetterOptions+            defaultRunCommandOptions+            counterProcessManager+            (inMemoryAdapter deadLetterDecisions badMessages)+            (const Nothing)+      deadLetterObserved <- readIORef deadLetterDecisions+      deadLetterObserved `shouldSatisfy` \case+        [AckDeadLetter (InvalidPayload _)] -> True+        _ -> False+      readIORef deadLetterRef `shouldReturn` badMessages++    it "folds a concurrent duplicate target dispatch to PMCommandDuplicate" $ \(_storeHandle, StoreRunner _runner) -> do+      insertCount <- newIORef (0 :: Int)+      let sourceEvent = recordedFromEventId (EventId sampleUuid) (CounterAdded 9)+          commandId = deterministicCommandId "counter-pm" "order-1" (sourceEvent ^. #eventId) 0+          targetStreamName = StreamName "counter-target-order-1"+          insertConcurrentTarget = do+            callNo <- atomicModifyIORef' insertCount (\n -> (n + 1, n))+            when (callNo == 1) $ appendCounterEventWithId _storeHandle targetStreamName commandId (CounterAdded 9)+          options =+            defaultRunCommandOptions+              & #beforeAppend+              .~ insertConcurrentTarget+              & #retryBackoffMicros+              .~ 0+      result <-+        _runner $+          runProcessManagerOnce options counterProcessManager sourceEvent (CounterAdded 9)+      case result of+        Right (Right pmResult) ->+          pmResult ^. #commandResults `shouldSatisfy` \case+            [PMCommandDuplicate duplicateId] -> duplicateId == commandId+            _ -> False+        other -> expectationFailure ("expected duplicate target dispatch fold, got " <> show other)+      Right targetEvents <-+        _runner $+          Store.readStreamForward targetStreamName (StreamVersion 0) 10+      Vector.length targetEvents `shouldBe` 1++    it "folds a concurrent duplicate manager-state append to PMStateDuplicate" $ \(_storeHandle, StoreRunner _runner) -> do+      insertCount <- newIORef (0 :: Int)+      let sourceEvent = recordedFromEventId (EventId sampleUuid) (CounterAdded 9)+          managerId = deterministicCommandId "counter-pm" "order-1" (sourceEvent ^. #eventId) (-1)+          managerStreamName = StreamName "pm:counter-order-1"+          insertConcurrentManager = do+            callNo <- atomicModifyIORef' insertCount (\n -> (n + 1, n))+            when (callNo == 0) $ appendCounterEventWithId _storeHandle managerStreamName managerId (CounterAdded 9)+          options =+            defaultRunCommandOptions+              & #beforeAppend+              .~ insertConcurrentManager+              & #retryBackoffMicros+              .~ 0+      result <-+        _runner $+          runProcessManagerOnce options counterProcessManager sourceEvent (CounterAdded 9)+      case result of+        Right (Right pmResult) -> do+          pmResult ^. #managerResult `shouldSatisfy` \case+            PMStateDuplicate duplicateId -> duplicateId == managerId+            _ -> False+          pmResult ^. #commandResults `shouldSatisfy` \case+            [PMCommandAppended {}] -> True+            _ -> False+        other -> expectationFailure ("expected duplicate manager-state fold, got " <> show other)++  describe "Keiro.ProcessManager duplicate confirmation" $ around (withFreshResourceStore fixture) $ do+    it "rejects a duplicate report carrying a different id" $ \(_storeHandle, StoreRunner _runner) -> do+      let targetStreamName = StreamName "duplicate-confirmation-mismatch"+          ourId = EventId sampleUuid+          otherId = EventId sampleUuid2+      appendCounterEventWithId _storeHandle targetStreamName otherId (CounterAdded 1)+      outcome <-+        _runner $+          confirmBenignDuplicate+            targetStreamName+            ourId+            (StoreFailed (Store.DuplicateEvent (Just otherId)))+      outcome `shouldBe` Right False++    it "rejects a matching id that exists only in another stream" $ \(_storeHandle, StoreRunner _runner) -> do+      let targetStreamName = StreamName "duplicate-confirmation-target"+          otherStreamName = StreamName "duplicate-confirmation-other"+          ourId = EventId sampleUuid+          targetEventId = EventId sampleUuid2+      appendCounterEventWithId _storeHandle targetStreamName targetEventId (CounterAdded 1)+      appendCounterEventWithId _storeHandle otherStreamName ourId (CounterAdded 1)+      outcome <-+        _runner $+          confirmBenignDuplicate+            targetStreamName+            ourId+            (StoreFailed (Store.DuplicateEvent (Just ourId)))+      outcome `shouldBe` Right False++    it "confirms matching and id-less duplicate reports when the id is in the target stream" $ \(_storeHandle, StoreRunner _runner) -> do+      let targetStreamName = StreamName "duplicate-confirmation-present"+          ourId = EventId sampleUuid+      appendCounterEventWithId _storeHandle targetStreamName ourId (CounterAdded 1)+      matchingOutcome <-+        _runner $+          confirmBenignDuplicate+            targetStreamName+            ourId+            (StoreFailed (Store.DuplicateEvent (Just ourId)))+      missingDetailOutcome <-+        _runner $+          confirmBenignDuplicate+            targetStreamName+            ourId+            (StoreFailed (Store.DuplicateEvent Nothing))+      matchingOutcome `shouldBe` Right True+      missingDetailOutcome `shouldBe` Right True++    it "rejects non-duplicate command failures" $ \(_storeHandle, StoreRunner _runner) -> do+      let targetStreamName = StreamName "duplicate-confirmation-non-duplicate"+          ourId = EventId sampleUuid+      appendCounterEventWithId _storeHandle targetStreamName ourId (CounterAdded 1)+      outcome <-+        _runner $+          confirmBenignDuplicate+            targetStreamName+            ourId+            (StoreFailed (Store.ConnectionLost "boom"))+      outcome `shouldBe` Right False++  describe "Keiro.ProcessManager snapshots" $ around (withFreshResourceStore fixture) $ do+    it "writes a snapshot of the manager state stream after the policy threshold" $ \(_storeHandle, StoreRunner _runner) -> do+      -- Two distinct source events, both correlating to "order-1", drive the one+      -- manager instance to manager-stream version 2, which Every 2 snapshots.+      let sourceA = recordedFromEventId (EventId sampleUuid) (CounterAdded 2)+          sourceB = recordedFromEventId (EventId sampleUuid2) (CounterAdded 3)+      Right (Right _) <-+        _runner $+          runProcessManagerOnce defaultRunCommandOptions pmSnapshotProcessManager sourceA (CounterAdded 2)+      Right (Right _) <-+        _runner $+          runProcessManagerOnce defaultRunCommandOptions pmSnapshotProcessManager sourceB (CounterAdded 3)+      Right managerEvents <-+        _runner $+          Store.readStreamForward (StreamName "pm:counter-snap-order-1") (StreamVersion 0) 10+      Vector.length managerEvents `shouldBe` 2+      Right snapshotVersion <-+        _runner $+          Store.runTransaction $+            Tx.statement "pm:counter-snap-order-1" snapshotVersionForStreamStmt+      snapshotVersion `shouldBe` Just (StreamVersion 2)++    it "hydrates the manager from its snapshot and replays only the tail" $ \(_storeHandle, StoreRunner _runner) -> do+      -- After the threshold snapshot exists, a third reaction should land on top of+      -- the snapshot at version 3 rather than replaying from version 0.+      let sourceA = recordedFromEventId (EventId sampleUuid) (CounterAdded 2)+          sourceB = recordedFromEventId (EventId sampleUuid2) (CounterAdded 3)+          sourceC = recordedFromEventId (EventId sampleUuid3) (CounterAdded 4)+      Right (Right _) <-+        _runner $+          runProcessManagerOnce defaultRunCommandOptions pmSnapshotProcessManager sourceA (CounterAdded 2)+      Right (Right _) <-+        _runner $+          runProcessManagerOnce defaultRunCommandOptions pmSnapshotProcessManager sourceB (CounterAdded 3)+      -- Confirm the snapshot is present before the tail-replay reaction.+      Right snapshotVersion <-+        _runner $+          Store.runTransaction $+            Tx.statement "pm:counter-snap-order-1" snapshotVersionForStreamStmt+      snapshotVersion `shouldBe` Just (StreamVersion 2)+      result <-+        _runner $+          runProcessManagerOnce defaultRunCommandOptions pmSnapshotProcessManager sourceC (CounterAdded 4)+      case result of+        Right (Right pmResult) ->+          case pmResult ^. #managerResult of+            PMStateAppended managerResult ->+              managerResult ^. #streamVersion `shouldBe` StreamVersion 3+            other -> expectationFailure ("expected appended manager state, got " <> show other)+        other -> expectationFailure ("expected snapshot-assisted PM reaction, got " <> show other)++  describe "Keiro.Router" $ around (withFreshResourceStore fixture) $ do+    it "encodes colon-bearing and non-ASCII id components without collisions" $ \(_storeHandle, StoreRunner _runner) -> do+      let sourceEventId = EventId sampleUuid+          colonLeft =+            deterministicRouterCommandId+              "router:a"+              "key"+              sourceEventId+              (StreamName "target")+              0+          colonRight =+            deterministicRouterCommandId+              "router"+              "a:key"+              sourceEventId+              (StreamName "target")+              0+          unicodeLeft =+            deterministicRouterCommandId+              "router"+              "key"+              sourceEventId+              (StreamName ("target-" <> Text.singleton '\x101'))+              0+          unicodeRight =+            deterministicRouterCommandId+              "router"+              "key"+              sourceEventId+              (StreamName ("target-" <> Text.singleton '\x201'))+              0+      colonLeft `shouldNotBe` colonRight+      unicodeLeft `shouldNotBe` unicodeRight++    it "resolves targets effectfully and fans out one command per target" $ \(_storeHandle, StoreRunner _runner) -> do+      Right () <-+        _runner $+          initializeRegisteredReadModel routerTargetsReadModel initializeRouterTargetsTable+      Right () <- _runner $+        Store.runTransaction $ do+          Tx.statement ("g1", "router-target-a") insertRouterTargetStmt+          Tx.statement ("g1", "router-target-b") insertRouterTargetStmt+          Tx.statement ("g1", "router-target-c") insertRouterTargetStmt+      let sourceEvent = recordedFromEventId (EventId sampleUuid) (CounterAdded 1)+      Right (RouterResult rs1) <-+        _runner $+          runRouterOnce defaultRunCommandOptions demoRouter sourceEvent (RouteGroup "g1")+      length rs1 `shouldBe` 3+      rs1 `shouldSatisfy` all isAppended+      -- Data-dependence is load-bearing: an unseeded group resolves to no+      -- targets, so the count tracks the read model, not a fixed list.+      Right (RouterResult rsEmpty) <-+        _runner $+          runRouterOnce defaultRunCommandOptions demoRouter sourceEvent (RouteGroup "no-such-group")+      length rsEmpty `shouldBe` 0+      -- Each resolved target stream received exactly one command.+      Right targetA <-+        _runner $+          Store.readStreamForward (StreamName "router-target-a") (StreamVersion 0) 10+      Right targetB <-+        _runner $+          Store.readStreamForward (StreamName "router-target-b") (StreamVersion 0) 10+      Right targetC <-+        _runner $+          Store.readStreamForward (StreamName "router-target-c") (StreamVersion 0) 10+      Vector.length targetA `shouldBe` 1+      Vector.length targetB `shouldBe` 1+      Vector.length targetC `shouldBe` 1++    it "reports every dispatch as a duplicate on replay, writing no new events" $ \(_storeHandle, StoreRunner _runner) -> do+      Right () <-+        _runner $+          initializeRegisteredReadModel routerTargetsReadModel initializeRouterTargetsTable+      Right () <- _runner $+        Store.runTransaction $ do+          Tx.statement ("g1", "router-target-a") insertRouterTargetStmt+          Tx.statement ("g1", "router-target-b") insertRouterTargetStmt+          Tx.statement ("g1", "router-target-c") insertRouterTargetStmt+      let sourceEvent = recordedFromEventId (EventId sampleUuid) (CounterAdded 1)+      Right (RouterResult rs1) <-+        _runner $+          runRouterOnce defaultRunCommandOptions demoRouter sourceEvent (RouteGroup "g1")+      rs1 `shouldSatisfy` all isAppended+      Right (RouterResult rs2) <-+        _runner $+          runRouterOnce defaultRunCommandOptions demoRouter sourceEvent (RouteGroup "g1")+      length rs2 `shouldBe` 3+      rs2 `shouldSatisfy` all isDuplicate+      -- Replay added nothing: each target stream still holds exactly one event.+      Right targetA <-+        _runner $+          Store.readStreamForward (StreamName "router-target-a") (StreamVersion 0) 10+      Right targetB <-+        _runner $+          Store.readStreamForward (StreamName "router-target-b") (StreamVersion 0) 10+      Right targetC <-+        _runner $+          Store.readStreamForward (StreamName "router-target-c") (StreamVersion 0) 10+      Vector.length targetA `shouldBe` 1+      Vector.length targetB `shouldBe` 1+      Vector.length targetC `shouldBe` 1++    it "dedups by target identity when a redelivered resolve reorders targets after a partial dispatch" $ \(_storeHandle, StoreRunner _runner) -> do+      attemptsRef <- newIORef (0 :: Int)+      let sourceEvent = recordedFromEventId (EventId sampleUuid) (CounterAdded 1)+          router = unstableRouter attemptsRef $ \case+            0 -> ["swap-a"]+            _ -> ["swap-b", "swap-a"]+      Right (RouterResult firstAttempt) <-+        _runner $+          runRouterOnce defaultRunCommandOptions router sourceEvent (RouteGroup "g1")+      firstAttempt `shouldSatisfy` all isAppended+      Right (RouterResult secondAttempt) <-+        _runner $+          runRouterOnce defaultRunCommandOptions router sourceEvent (RouteGroup "g1")+      secondAttempt `shouldSatisfy` \case+        [swapB, swapA] -> isAppended swapB && isDuplicate swapA+        _ -> False+      Right swapAEvents <-+        _runner $+          Store.readStreamForward (StreamName "swap-a") (StreamVersion 0) 10+      Right swapBEvents <-+        _runner $+          Store.readStreamForward (StreamName "swap-b") (StreamVersion 0) 10+      Vector.length swapAEvents `shouldBe` 1+      Vector.length swapBEvents `shouldBe` 1++    it "dispatches a target added by resolve drift instead of misreading it as a duplicate" $ \(_storeHandle, StoreRunner _runner) -> do+      attemptsRef <- newIORef (0 :: Int)+      let sourceEvent = recordedFromEventId (EventId sampleUuid) (CounterAdded 1)+          router = unstableRouter attemptsRef $ \case+            0 -> ["growth-a", "growth-b"]+            _ -> ["growth-a", "growth-c"]+      Right (RouterResult firstAttempt) <-+        _runner $+          runRouterOnce defaultRunCommandOptions router sourceEvent (RouteGroup "g1")+      firstAttempt `shouldSatisfy` all isAppended+      Right (RouterResult secondAttempt) <-+        _runner $+          runRouterOnce defaultRunCommandOptions router sourceEvent (RouteGroup "g1")+      secondAttempt `shouldSatisfy` \case+        [growthA, growthC] -> isDuplicate growthA && isAppended growthC+        _ -> False+      Right growthAEvents <-+        _runner $+          Store.readStreamForward (StreamName "growth-a") (StreamVersion 0) 10+      Right growthBEvents <-+        _runner $+          Store.readStreamForward (StreamName "growth-b") (StreamVersion 0) 10+      Right growthCEvents <-+        _runner $+          Store.readStreamForward (StreamName "growth-c") (StreamVersion 0) 10+      Vector.length growthAEvents `shouldBe` 1+      Vector.length growthBEvents `shouldBe` 1+      Vector.length growthCEvents `shouldBe` 1++    it "keeps full-completion order swaps idempotent" $ \(_storeHandle, StoreRunner _runner) -> do+      attemptsRef <- newIORef (0 :: Int)+      let sourceEvent = recordedFromEventId (EventId sampleUuid) (CounterAdded 1)+          router = unstableRouter attemptsRef $ \case+            0 -> ["order-a", "order-b"]+            _ -> ["order-b", "order-a"]+      Right (RouterResult firstAttempt) <-+        _runner $+          runRouterOnce defaultRunCommandOptions router sourceEvent (RouteGroup "g1")+      firstAttempt `shouldSatisfy` all isAppended+      Right (RouterResult secondAttempt) <-+        _runner $+          runRouterOnce defaultRunCommandOptions router sourceEvent (RouteGroup "g1")+      secondAttempt `shouldSatisfy` all isDuplicate+      Right orderAEvents <-+        _runner $+          Store.readStreamForward (StreamName "order-a") (StreamVersion 0) 10+      Right orderBEvents <-+        _runner $+          Store.readStreamForward (StreamName "order-b") (StreamVersion 0) 10+      Vector.length orderAEvents `shouldBe` 1+      Vector.length orderBEvents `shouldBe` 1++    it "keeps dispatches to targets dropped by a later resolve attempt" $ \(_storeHandle, StoreRunner _runner) -> do+      attemptsRef <- newIORef (0 :: Int)+      let sourceEvent = recordedFromEventId (EventId sampleUuid) (CounterAdded 1)+          router = unstableRouter attemptsRef $ \case+            0 -> ["drop-a", "drop-b"]+            _ -> ["drop-b"]+      Right (RouterResult firstAttempt) <-+        _runner $+          runRouterOnce defaultRunCommandOptions router sourceEvent (RouteGroup "g1")+      firstAttempt `shouldSatisfy` all isAppended+      Right (RouterResult secondAttempt) <-+        _runner $+          runRouterOnce defaultRunCommandOptions router sourceEvent (RouteGroup "g1")+      secondAttempt `shouldSatisfy` \case+        [dropB] -> isDuplicate dropB+        _ -> False+      -- Resolve is authoritative per attempt. Across redeliveries, the+      -- dispatched set is the union of each attempt's resolved targets.+      Right dropAEvents <-+        _runner $+          Store.readStreamForward (StreamName "drop-a") (StreamVersion 0) 10+      Right dropBEvents <-+        _runner $+          Store.readStreamForward (StreamName "drop-b") (StreamVersion 0) 10+      Vector.length dropAEvents `shouldBe` 1+      Vector.length dropBEvents `shouldBe` 1++    it "keeps repeated commands to one target distinct within a resolve batch" $ \(_storeHandle, StoreRunner _runner) -> do+      attemptsRef <- newIORef (0 :: Int)+      let sourceEvent = recordedFromEventId (EventId sampleUuid) (CounterAdded 1)+          router = unstableRouter attemptsRef (const ["twin", "twin"])+      Right (RouterResult firstAttempt) <-+        _runner $+          runRouterOnce defaultRunCommandOptions router sourceEvent (RouteGroup "g1")+      firstAttempt `shouldSatisfy` all isAppended+      Right twinEventsAfterFirstAttempt <-+        _runner $+          Store.readStreamForward (StreamName "twin") (StreamVersion 0) 10+      Vector.length twinEventsAfterFirstAttempt `shouldBe` 2+      Right (RouterResult secondAttempt) <-+        _runner $+          runRouterOnce defaultRunCommandOptions router sourceEvent (RouteGroup "g1")+      secondAttempt `shouldSatisfy` all isDuplicate+      Right twinEventsAfterSecondAttempt <-+        _runner $+          Store.readStreamForward (StreamName "twin") (StreamVersion 0) 10+      Vector.length twinEventsAfterSecondAttempt `shouldBe` 2++    it "drains an adapter, dispatching one command per resolved target for every message" $ \(_storeHandle, StoreRunner _runner) -> do+      Right () <-+        _runner $+          initializeRegisteredReadModel routerTargetsReadModel initializeRouterTargetsTable+      Right () <- _runner $+        Store.runTransaction $ do+          Tx.statement ("g1", "worker-a") insertRouterTargetStmt+          Tx.statement ("g1", "worker-b") insertRouterTargetStmt+          Tx.statement ("g2", "worker-c") insertRouterTargetStmt+      decisionsRef <- newIORef []+      let sourceEvent1 = recordedFromEventId (EventId sampleUuid) (CounterAdded 1)+          sourceEvent2 = recordedFromEventId (EventId sampleUuid2) (CounterAdded 1)+          messages =+            [ (sourceEvent1, RouteGroup "g1"),+              (sourceEvent2, RouteGroup "g2")+            ]+          adapter = inMemoryAdapter decisionsRef messages+      Right () <-+        _runner $+          runRouterWorker defaultRunCommandOptions demoRouter adapter Just+      decisions <- readIORef decisionsRef+      decisions `shouldBe` [AckOk, AckOk]+      Right wa <-+        _runner $+          Store.readStreamForward (StreamName "worker-a") (StreamVersion 0) 10+      Right wb <-+        _runner $+          Store.readStreamForward (StreamName "worker-b") (StreamVersion 0) 10+      Right wc <-+        _runner $+          Store.readStreamForward (StreamName "worker-c") (StreamVersion 0) 10+      Vector.length wa `shouldBe` 1+      Vector.length wb `shouldBe` 1+      Vector.length wc `shouldBe` 1++    it "finalizes AckHalt rather than AckOk when a dispatched command fails" $ \(_storeHandle, StoreRunner _runner) -> do+      decisionsRef <- newIORef []+      let sourceEvent = recordedFromEventId (EventId sampleUuid) (CounterAdded 1)+          messages = [(sourceEvent, RouteGroup "g1")]+          adapter = inMemoryAdapter decisionsRef messages+      Right () <-+        _runner $+          runRouterWorker defaultRunCommandOptions failingRouter adapter Just+      decisions <- readIORef decisionsRef+      decisions `shouldSatisfy` \case+        [AckHalt (HaltFatal _)] -> True+        _ -> False++    it "dead-letters a rejected router dispatch and acknowledges the source event" $ \(_storeHandle, StoreRunner _runner) -> do+      decisionsRef <- newIORef []+      let sourceEvent = recordedFromEventId (EventId sampleUuid) (CounterAdded 1)+          adapter = inMemoryAdapter decisionsRef [(sourceEvent, RouteGroup "g1")]+          workerOptions = defaultWorkerOptions & #rejectedCommandPolicy .~ RejectedDeadLetter+      Right () <-+        _runner $+          runRouterWorkerWith workerOptions defaultRunCommandOptions failingRouter adapter Just+      readIORef decisionsRef `shouldReturn` [AckOk]+      Right deadLetters <- _runner (listDispatchDeadLetters "failing-router")+      case deadLetters of+        [row] -> do+          row ^. #dispatcherKind `shouldBe` DispatcherRouter+          row ^. #correlationId `shouldBe` "g1"+          row ^. #targetStreamName `shouldBe` StreamName "failing-target"+          row ^. #errorClass `shouldBe` "command_rejected"+        other -> expectationFailure ("expected one router dead letter, got " <> show other)++    it "finalizes AckRetry for a transient thrown resolver error and continues" $ \(_storeHandle, StoreRunner _runner) -> do+      Right () <-+        _runner $+          initializeRegisteredReadModel routerTargetsReadModel initializeRouterTargetsTable+      Right () <-+        _runner $+          Store.runTransaction (Tx.statement ("g2", "worker-after-retry") insertRouterTargetStmt)+      decisionsRef <- newIORef []+      attemptsRef <- newIORef (0 :: Int)+      let sourceEvent1 = recordedFromEventId (EventId sampleUuid) (CounterAdded 1)+          sourceEvent2 = recordedFromEventId (EventId sampleUuid2) (CounterAdded 1)+          messages = [(sourceEvent1, RouteGroup "g1"), (sourceEvent2, RouteGroup "g2")]+          adapter = inMemoryAdapter decisionsRef messages+          flakyRouter ::+            (IOE :> es, Store :> es, Error Store.StoreError :> es) =>+            Router RouteGroup (HsPred '[] CounterCommand) '[] CounterState CounterCommand CounterEvent es+          flakyRouter =+            Router+              { name = "flaky-router",+                key = \(RouteGroup g) -> g,+                resolve = \(RouteGroup g) -> do+                  attempt <- liftIO (atomicModifyIORef' attemptsRef (\n -> (n + 1, n)))+                  if attempt == 0+                    then throwError (Store.ConnectionLost "injected")+                    else do+                      result <- runQuery Nothing routerTargetsReadModel g+                      pure $ case result of+                        Right targetIds ->+                          [ PMCommand {target = stream targetId, command = Add 1}+                          | targetId <- targetIds+                          ]+                        Left _ -> [],+                targetEventStream = counterEventStream,+                targetProjections = const []+              }+      Right () <-+        _runner $+          runRouterWorker defaultRunCommandOptions flakyRouter adapter Just+      decisions <- readIORef decisionsRef+      decisions `shouldSatisfy` \case+        [AckRetry {}, AckOk] -> True+        _ -> False++    it "finalizes AckHalt for a deterministic thrown resolver error" $ \(_storeHandle, StoreRunner _runner) -> do+      decisionsRef <- newIORef []+      let sourceEvent = recordedFromEventId (EventId sampleUuid) (CounterAdded 1)+          messages = [(sourceEvent, RouteGroup "g1")]+          adapter = inMemoryAdapter decisionsRef messages+          failingResolveRouter ::+            (Error Store.StoreError :> es) =>+            Router RouteGroup (HsPred '[] CounterCommand) '[] CounterState CounterCommand CounterEvent es+          failingResolveRouter =+            Router+              { name = "failing-resolve-router",+                key = \(RouteGroup g) -> g,+                resolve = \_ -> throwError (Store.UnexpectedServerError "XX000" "boom"),+                targetEventStream = counterEventStream,+                targetProjections = const []+              }+      Right () <-+        _runner $+          runRouterWorker defaultRunCommandOptions failingResolveRouter adapter Just+      decisions <- readIORef decisionsRef+      decisions `shouldSatisfy` \case+        [AckHalt (HaltFatal _)] -> True+        _ -> False++    it "folds a concurrent duplicate router dispatch to PMCommandDuplicate" $ \(_storeHandle, StoreRunner _runner) -> do+      Right () <-+        _runner $+          initializeRegisteredReadModel routerTargetsReadModel initializeRouterTargetsTable+      Right () <-+        _runner $+          Store.runTransaction (Tx.statement ("g1", "router-duplicate-target") insertRouterTargetStmt)+      insertCount <- newIORef (0 :: Int)+      let sourceEvent = recordedFromEventId (EventId sampleUuid) (CounterAdded 1)+          targetStreamName = StreamName "router-duplicate-target"+          commandId =+            deterministicRouterCommandId+              "demo-router"+              "g1"+              (sourceEvent ^. #eventId)+              targetStreamName+              0+          insertConcurrentTarget = do+            callNo <- atomicModifyIORef' insertCount (\n -> (n + 1, n))+            when (callNo == 0) $ appendCounterEventWithId _storeHandle targetStreamName commandId (CounterAdded 1)+          options =+            defaultRunCommandOptions+              & #beforeAppend+              .~ insertConcurrentTarget+              & #retryBackoffMicros+              .~ 0+      result <-+        _runner $+          runRouterOnce options demoRouter sourceEvent (RouteGroup "g1")+      case result of+        Right (RouterResult [PMCommandDuplicate duplicateId]) ->+          duplicateId `shouldBe` commandId+        other -> expectationFailure ("expected duplicate router dispatch fold, got " <> show other)+      Right targetEvents <-+        _runner $+          Store.readStreamForward targetStreamName (StreamVersion 0) 10+      Vector.length targetEvents `shouldBe` 1++    it "dedups a pre-upgrade positional router dispatch during the transition" $ \(_storeHandle, StoreRunner _runner) -> do+      Right () <-+        _runner $+          initializeRegisteredReadModel routerTargetsReadModel initializeRouterTargetsTable+      Right () <-+        _runner $+          Store.runTransaction (Tx.statement ("g1", "transition-target") insertRouterTargetStmt)+      let sourceEvent = recordedFromEventId (EventId sampleUuid) (CounterAdded 1)+          legacyId = deterministicCommandId "demo-router" "g1" (sourceEvent ^. #eventId) 0+          targetStreamName = StreamName "transition-target"+      appendCounterEventWithId _storeHandle targetStreamName legacyId (CounterAdded 1)+      result <-+        _runner $+          runRouterOnce defaultRunCommandOptions demoRouter sourceEvent (RouteGroup "g1")+      case result of+        Right (RouterResult [PMCommandDuplicate duplicateId]) ->+          duplicateId `shouldBe` legacyId+        other -> expectationFailure ("expected transition duplicate, got " <> show other)+      Right targetEvents <-+        _runner $+          Store.readStreamForward targetStreamName (StreamVersion 0) 10+      Vector.length targetEvents `shouldBe` 1++  describe "Keiro.Timer" $ around (withFreshStore fixture) $ do+    it "validates worker options before startup" $ \_storeHandle -> do+      shouldBeRight_ (mkTimerWorkerOptions defaultTimerWorkerOptions)+      mkTimerWorkerOptions (defaultTimerWorkerOptions & #maxAttempts ?~ (-1))+        `shouldBeLeft` InvalidTimerMaxAttempts (-1)+      mkTimerWorkerOptions (defaultTimerWorkerOptions & #requeueStuckAfter ?~ 0)+        `shouldBeLeft` InvalidTimerRequeueStuckAfter 0++    it "claims a due timer, fires a command, and marks it complete once" $ \storeHandle -> do+      Right () <-+        Store.runStoreIO storeHandle $+          Store.runTransaction $+            scheduleTimerTx counterTimerRequest+      let firedEventId = EventId sampleUuid2+      workerResult <- Store.runStoreIO storeHandle $+        runTimerWorker Nothing dueTimerTime $ \_ -> do+          fired <-+            runCommand+              (defaultRunCommandOptions & #eventIds .~ [firedEventId])+              counterEventStream+              (stream "timer-target")+              (Add 11)+          case fired of+            Right _ -> pure (Just firedEventId)+            Left err -> liftIO (expectationFailure ("expected timer command to fire, got " <> show err)) *> pure Nothing+      case workerResult of+        Right (Just timer) ->+          timer ^. #status `shouldBe` Firing+        other -> expectationFailure ("expected fired timer, got " <> show other)+      secondWorkerResult <-+        Store.runStoreIO storeHandle $+          runTimerWorker Nothing dueTimerTime (\_ -> pure (Just firedEventId))+      secondWorkerResult `shouldBe` Right Nothing+      Right targetEvents <-+        Store.runStoreIO storeHandle $+          Store.readStreamForward (StreamName "timer-target") (StreamVersion 0) 10+      fmap (^. #eventId) (Vector.toList targetEvents) `shouldBe` [firedEventId]++    it "records timer backlog, fire lag, attempts, and stuck count" $ \storeHandle -> do+      (exporter, metricsRef) <- inMemoryMetricExporter+      (provider, _env) <-+        createMeterProvider+          emptyMaterializedResources+          defaultSdkMeterProviderOptions {metricExporter = Just exporter}+      meter <- getMeter provider Telemetry.keiroInstrumentationLibrary+      keiroMetrics <- Telemetry.newKeiroMetrics meter+      Right () <-+        Store.runStoreIO storeHandle $+          Store.runTransaction $+            scheduleTimerTx counterTimerRequest+      let firedEventId = EventId sampleUuid2+      workerResult <-+        Store.runStoreIO storeHandle $+          runTimerWorker (Just keiroMetrics) dueTimerTime (\_ -> pure (Just firedEventId))+      case workerResult of+        Right (Just _) -> pure ()+        other -> expectationFailure ("expected a fired timer, got " <> show other)+      _ <- forceFlushMeterProvider provider Nothing+      exported <- readIORef metricsRef+      let scalars = flattenScalarPoints exported+          hists = flattenHistogramPoints exported+      -- One scheduled+due row at the start of the pass: backlog gauge holds 1.+      lookup "keiro.timer.backlog" scalars `shouldBe` Just (IntNumber 1)+      -- Nothing was stranded in 'firing' before this pass: stuck gauge holds 0.+      lookup "keiro.timer.stuck" scalars `shouldBe` Just (IntNumber 0)+      -- The claimed timer was due exactly at 'now' and is on its first attempt:+      -- one fire.lag observation of 0 ms and one attempts observation of 1.+      [(c, s) | (n, c, s) <- hists, n == "keiro.timer.fire.lag"] `shouldBe` [(1, 0.0)]+      [(c, s) | (n, c, s) <- hists, n == "keiro.timer.attempts"] `shouldBe` [(1, 1.0)]++    it "finds a firing timer with findStuckTimers and requeues it for re-firing" $ \storeHandle -> do+      Right () <-+        Store.runStoreIO storeHandle $+          Store.runTransaction $+            scheduleTimerTx counterTimerRequest+      -- Strand it in Firing by claiming without firing.+      claimed <- Store.runStoreIO storeHandle $ claimDueTimer dueTimerTime+      case claimed of+        Right (Just timer) -> timer ^. #status `shouldBe` Firing+        other -> expectationFailure ("expected a claimed timer, got " <> show other)+      -- It surfaces as stuck under the permissive filter.+      Right stuck <-+        Store.runStoreIO storeHandle $+          findStuckTimers dueTimerTime anyStuckTimer+      fmap (^. #timerId) stuck `shouldBe` [counterTimerRequest ^. #timerId]+      -- A bound it does not meet (only one attempt) excludes it.+      Right unmatched <-+        Store.runStoreIO storeHandle $+          findStuckTimers dueTimerTime (StuckTimerFilter Nothing (Just 5))+      unmatched `shouldBe` []+      -- Requeue is idempotent: True the first time, False once it is scheduled.+      requeued <-+        Store.runStoreIO storeHandle $+          requeueStuckTimer (counterTimerRequest ^. #timerId)+      requeued `shouldBe` Right True+      requeuedAgain <-+        Store.runStoreIO storeHandle $+          requeueStuckTimer (counterTimerRequest ^. #timerId)+      requeuedAgain `shouldBe` Right False+      -- The ordinary loop re-claims and fires it exactly once.+      let firedEventId = EventId sampleUuid2+      workerResult <- Store.runStoreIO storeHandle $+        runTimerWorker Nothing dueTimerTime $ \_ -> do+          fired <-+            runCommand+              (defaultRunCommandOptions & #eventIds .~ [firedEventId])+              counterEventStream+              (stream "timer-target")+              (Add 7)+          case fired of+            Right _ -> pure (Just firedEventId)+            Left err -> liftIO (expectationFailure ("expected timer command to fire, got " <> show err)) *> pure Nothing+      case workerResult of+        Right (Just timer) ->+          timer ^. #status `shouldBe` Firing+        other -> expectationFailure ("expected re-fired timer, got " <> show other)+      secondWorkerResult <-+        Store.runStoreIO storeHandle $+          runTimerWorker Nothing dueTimerTime (\_ -> pure (Just firedEventId))+      secondWorkerResult `shouldBe` Right Nothing+      Right targetEvents <-+        Store.runStoreIO storeHandle $+          Store.readStreamForward (StreamName "timer-target") (StreamVersion 0) 10+      fmap (^. #eventId) (Vector.toList targetEvents) `shouldBe` [firedEventId]++    it "re-fires a timer stranded by a crashed worker" $ \storeHandle -> do+      Right () <-+        Store.runStoreIO storeHandle $+          Store.runTransaction $+            scheduleTimerTx counterTimerRequest+      Right (Just claimed) <- Store.runStoreIO storeHandle $ claimDueTimer dueTimerTime+      claimed ^. #status `shouldBe` Firing+      realNow <- getCurrentTime+      firedRef <- newIORef []+      let futureNow = addUTCTime 400 realNow+          firedEventId = EventId sampleUuid2+      workerResult <-+        Store.runStoreIO storeHandle $+          runTimerWorker Nothing futureNow $ \timer -> do+            liftIO (modifyIORef' firedRef (<> [timer ^. #timerId]))+            pure (Just firedEventId)+      case workerResult of+        Right (Just timer) -> timer ^. #timerId `shouldBe` counterTimerRequest ^. #timerId+        other -> expectationFailure ("expected stale timer to be requeued and claimed, got " <> show other)+      firedTimers <- readIORef firedRef+      firedTimers `shouldBe` [counterTimerRequest ^. #timerId]+      Right statusRow <-+        Store.runStoreIO storeHandle $+          Store.runTransaction $+            Tx.statement sampleUuid timerStatusAndErrorStmt+      statusRow `shouldBe` Just ("fired", Nothing)+      secondWorkerResult <-+        Store.runStoreIO storeHandle $+          runTimerWorker Nothing futureNow (\_ -> pure (Just firedEventId))+      secondWorkerResult `shouldBe` Right Nothing++    it "does not requeue a fresh firing row" $ \storeHandle -> do+      Right () <-+        Store.runStoreIO storeHandle $+          Store.runTransaction $+            scheduleTimerTx counterTimerRequest+      Right (Just _) <- Store.runStoreIO storeHandle $ claimDueTimer dueTimerTime+      realNow <- getCurrentTime+      firedRef <- newIORef False+      workerResult <-+        Store.runStoreIO storeHandle $+          runTimerWorker Nothing realNow $ \_ -> do+            liftIO (writeIORef firedRef True)+            pure (Just (EventId sampleUuid2))+      workerResult `shouldBe` Right Nothing+      didFire <- readIORef firedRef+      didFire `shouldBe` False+      Right statusRow <-+        Store.runStoreIO storeHandle $+          Store.runTransaction $+            Tx.statement sampleUuid timerStatusAndErrorStmt+      statusRow `shouldBe` Just ("firing", Nothing)++    it "requeueStuckAfter = Nothing preserves a stranded firing row" $ \storeHandle -> do+      Right () <-+        Store.runStoreIO storeHandle $+          Store.runTransaction $+            scheduleTimerTx counterTimerRequest+      Right (Just _) <- Store.runStoreIO storeHandle $ claimDueTimer dueTimerTime+      realNow <- getCurrentTime+      firedRef <- newIORef False+      let opts = defaultTimerWorkerOptions & #requeueStuckAfter .~ Nothing+      workerResult <-+        Store.runStoreIO storeHandle $+          runTimerWorkerWith Nothing opts (addUTCTime 400 realNow) $ \_ -> do+            liftIO (writeIORef firedRef True)+            pure (Just (EventId sampleUuid2))+      workerResult `shouldBe` Right Nothing+      didFire <- readIORef firedRef+      didFire `shouldBe` False+      Right statusRow <-+        Store.runStoreIO storeHandle $+          Store.runTransaction $+            Tx.statement sampleUuid timerStatusAndErrorStmt+      statusRow `shouldBe` Just ("firing", Nothing)++    it "does not claim a cancelled timer" $ \storeHandle -> do+      Right () <-+        Store.runStoreIO storeHandle $+          Store.runTransaction $+            scheduleTimerTx counterTimerRequest+      cancelled <-+        Store.runStoreIO storeHandle $+          cancelTimer (counterTimerRequest ^. #timerId)+      cancelled `shouldBe` Right True+      claimed <- Store.runStoreIO storeHandle $ claimDueTimer dueTimerTime+      claimed `shouldBe` Right Nothing+      cancelledAgain <-+        Store.runStoreIO storeHandle $+          cancelTimer (counterTimerRequest ^. #timerId)+      cancelledAgain `shouldBe` Right False++    it "dead-letters a timer that exceeds the attempt ceiling and never reclaims it" $ \storeHandle -> do+      Right () <-+        Store.runStoreIO storeHandle $+          Store.runTransaction $+            scheduleTimerTx counterTimerRequest+      firedRef <- newIORef False+      let firedEventId = EventId sampleUuid2+      -- maxAttempts = Just 0: the first claim sets attempts = 1 > 0, so the+      -- worker dead-letters instead of firing.+      result <- Store.runStoreIO storeHandle $+        runTimerWorkerWith Nothing (defaultTimerWorkerOptions & #maxAttempts .~ Just 0) dueTimerTime $ \_ -> do+          liftIO (writeIORef firedRef True)+          pure (Just firedEventId)+      case result of+        Right (Just timer) ->+          timer ^. #status `shouldBe` Firing+        other -> expectationFailure ("expected a claimed timer, got " <> show other)+      -- The fire action never ran.+      didFire <- readIORef firedRef+      didFire `shouldBe` False+      -- The row landed in 'dead' with the expected reason in last_error.+      Right statusRow <-+        Store.runStoreIO storeHandle $+          Store.runTransaction $+            Tx.statement sampleUuid timerStatusAndErrorStmt+      statusRow `shouldBe` Just ("dead", Just "timer exceeded attempt ceiling of 0")+      -- A dead row is never re-claimed.+      secondWorkerResult <-+        Store.runStoreIO storeHandle $+          runTimerWorker Nothing dueTimerTime (\_ -> pure (Just firedEventId))+      secondWorkerResult `shouldBe` Right Nothing++    it "markTimerFired does not resurrect a dead timer" $ \storeHandle -> do+      Right () <-+        Store.runStoreIO storeHandle $+          Store.runTransaction $+            scheduleTimerTx counterTimerRequest+      Right (Just _) <- Store.runStoreIO storeHandle $ claimDueTimer dueTimerTime+      deadened <-+        Store.runStoreIO storeHandle $+          deadLetterTimer (counterTimerRequest ^. #timerId) "operator dead-letter"+      deadened `shouldBe` Right True+      marked <-+        Store.runStoreIO storeHandle $+          markTimerFired (counterTimerRequest ^. #timerId) (EventId sampleUuid2)+      marked `shouldBe` Right False+      Right statusRow <-+        Store.runStoreIO storeHandle $+          Store.runTransaction $+            Tx.statement sampleUuid timerStatusAndErrorStmt+      statusRow `shouldBe` Just ("dead", Just "operator dead-letter")++    it "records a row stranded in Firing in the stuck gauge" $ \storeHandle -> do+      (exporter, metricsRef) <- inMemoryMetricExporter+      (provider, _env) <-+        createMeterProvider+          emptyMaterializedResources+          defaultSdkMeterProviderOptions {metricExporter = Just exporter}+      meter <- getMeter provider Telemetry.keiroInstrumentationLibrary+      keiroMetrics <- Telemetry.newKeiroMetrics meter+      Right () <-+        Store.runStoreIO storeHandle $+          Store.runTransaction $+            scheduleTimerTx counterTimerRequest+      -- Strand it in Firing by claiming without firing (a crashed worker).+      Right (Just _) <- Store.runStoreIO storeHandle $ claimDueTimer dueTimerTime+      -- A later pass finds nothing scheduled and due, but sees the stranded row.+      workerResult <-+        Store.runStoreIO storeHandle $+          runTimerWorker (Just keiroMetrics) dueTimerTime (\_ -> pure Nothing)+      workerResult `shouldBe` Right Nothing+      _ <- forceFlushMeterProvider provider Nothing+      exported <- readIORef metricsRef+      let scalars = flattenScalarPoints exported+      -- The one firing row is counted as stuck.+      lookup "keiro.timer.stuck" scalars `shouldBe` Just (IntNumber 1)+      -- It is not 'scheduled', so it does not show up as backlog.+      lookup "keiro.timer.backlog" scalars `shouldBe` Just (IntNumber 0)++  describe "Keiro.Outbox.Kafka" $ do+    it "converts an outbox row to a Kafka producer record" $ do+      let envelope = sampleIntegrationEnvelope+          row = sampleOutboxRow envelope+          record = OutboxKafka.outboxRowToKafkaRecord row+      record ^. #topic `shouldBe` envelope ^. #destination+      record ^. #key `shouldBe` Just "order-123"+      record ^. #payload `shouldBe` envelope ^. #payloadBytes+      -- Headers include identity fields and content type.+      let headers = record ^. #headers+          messageIdHeader = Prelude.lookup "keiro-message-id" headers+      messageIdHeader `shouldBe` Just "018f0f18-17aa-7000-8000-0000000000aa"++    it "drops the partition key when the envelope has no key" $ do+      let envelope = sampleIntegrationEnvelope & #key .~ Nothing+          record = OutboxKafka.integrationEventToKafkaRecord envelope+      record ^. #key `shouldBe` Nothing++  describe "Keiro.Outbox" $ around (withFreshStore fixture) $ do+    it "validates publisher options before startup" $ \_storeHandle -> do+      shouldBeRight_ (mkOutboxPublishOptions defaultPublishOptions)+      mkOutboxPublishOptions (defaultPublishOptions & #batchSize .~ 0)+        `shouldBeLeft` InvalidOutboxBatchSize 0+      mkOutboxPublishOptions (defaultPublishOptions & #maxAttempts .~ 0)+        `shouldBeLeft` InvalidOutboxMaxAttempts 0+      mkOutboxPublishOptions (defaultPublishOptions & #publishingTimeout .~ 0)+        `shouldBeLeft` InvalidOutboxPublishingTimeout 0+      mkOutboxPublishOptions (defaultPublishOptions & #backoff .~ ConstantBackoff (-1))+        `shouldBeLeft` InvalidConstantBackoff (-1)+      mkOutboxPublishOptions+        ( defaultPublishOptions+            & #backoff+            .~ ExponentialBackoff+              ExponentialBackoffOptions+                { initial = 0,+                  maxDelay = 1,+                  multiplier = 2+                }+        )+        `shouldBeLeft` InvalidExponentialBackoffInitial 0+      mkOutboxPublishOptions+        ( defaultPublishOptions+            & #backoff+            .~ ExponentialBackoff+              ExponentialBackoffOptions+                { initial = 1,+                  maxDelay = 10,+                  multiplier = 0.5+                }+        )+        `shouldBeLeft` InvalidExponentialBackoffMultiplier 0.5+      mkOutboxPublishOptions+        ( defaultPublishOptions+            & #backoff+            .~ ExponentialBackoff+              ExponentialBackoffOptions+                { initial = 5,+                  maxDelay = 4,+                  multiplier = 2+                }+        )+        `shouldBeLeft` InvalidExponentialBackoffMaxDelay 5 4++    it "enqueues and looks up an outbox row" $ \storeHandle -> do+      let envelope = sampleIntegrationEnvelope+          oid = OutboxId outboxUuid1+      Right () <-+        Store.runStoreIO storeHandle $+          Store.runTransaction (enqueueIntegrationEventTx oid envelope)+      lookedUp <- Store.runStoreIO storeHandle (lookupOutbox oid)+      case lookedUp of+        Right (Just row) -> do+          row ^. #outboxId `shouldBe` oid+          row ^. #status `shouldBe` OutboxPending+          row ^. #attemptCount `shouldBe` 0+          row ^. #event . #messageId `shouldBe` envelope ^. #messageId+          row ^. #event . #destination `shouldBe` envelope ^. #destination+          row ^. #event . #payloadBytes `shouldBe` envelope ^. #payloadBytes+        other -> expectationFailure ("expected enqueued row, got " <> show other)++    it "claims a pending row, transitions it to publishing, and increments attempt count" $ \storeHandle -> do+      let oid = OutboxId outboxUuid1+      Right () <-+        Store.runStoreIO storeHandle $+          Store.runTransaction (enqueueIntegrationEventTx oid sampleIntegrationEnvelope)+      now <- getCurrentTime+      Right rows <- Store.runStoreIO storeHandle (claimOutboxBatch PerKeyHeadOfLine 10 now)+      case rows of+        [row] -> do+          row ^. #outboxId `shouldBe` oid+          row ^. #status `shouldBe` OutboxPublishing+          row ^. #attemptCount `shouldBe` 1+        other -> expectationFailure ("expected one claimed row, got " <> show other)++    it "claims contiguous per-key runs in one pass" $ \storeHandle -> do+      let keyedRows =+            [ (outboxIdFromOrdinal 1, sampleIntegrationEnvelope & #messageId .~ "run-a1" & #key .~ Just "A"),+              (outboxIdFromOrdinal 2, sampleIntegrationEnvelope & #messageId .~ "run-a2" & #key .~ Just "A"),+              (outboxIdFromOrdinal 3, sampleIntegrationEnvelope & #messageId .~ "run-a3" & #key .~ Just "A"),+              (outboxIdFromOrdinal 4, sampleIntegrationEnvelope & #messageId .~ "run-a4" & #key .~ Just "A"),+              (outboxIdFromOrdinal 5, sampleIntegrationEnvelope & #messageId .~ "run-a5" & #key .~ Just "A"),+              (outboxIdFromOrdinal 6, sampleIntegrationEnvelope & #messageId .~ "run-b1" & #key .~ Just "B"),+              (outboxIdFromOrdinal 7, sampleIntegrationEnvelope & #messageId .~ "run-b2" & #key .~ Just "B"),+              (outboxIdFromOrdinal 8, sampleIntegrationEnvelope & #messageId .~ "run-b3" & #key .~ Just "B")+            ]+      Right () <-+        Store.runStoreIO storeHandle $+          Store.runTransaction $+            traverse_ (uncurry enqueueIntegrationEventTx) keyedRows+      now <- getCurrentTime+      Right rows <- Store.runStoreIO storeHandle (claimOutboxBatch PerKeyHeadOfLine 10 now)+      fmap (^. #outboxId) rows `shouldBe` fmap fst keyedRows+      fmap (^. #attemptCount) rows `shouldBe` replicate 8 1++    it "does not let a backoff head starve other keys" $ \storeHandle -> do+      let a1Id = outboxIdFromOrdinal 1+          a2Id = outboxIdFromOrdinal 2+          b1Id = outboxIdFromOrdinal 3+          b2Id = outboxIdFromOrdinal 4+          rows =+            [ (a1Id, sampleIntegrationEnvelope & #messageId .~ "backoff-a1" & #key .~ Just "A"),+              (a2Id, sampleIntegrationEnvelope & #messageId .~ "backoff-a2" & #key .~ Just "A"),+              (b1Id, sampleIntegrationEnvelope & #messageId .~ "backoff-b1" & #key .~ Just "B"),+              (b2Id, sampleIntegrationEnvelope & #messageId .~ "backoff-b2" & #key .~ Just "B")+            ]+          failA1 row+            | row ^. #outboxId == a1Id = pure (PublishFailed "wait")+            | otherwise = pure PublishSucceeded+          opts =+            defaultPublishOptions+              & #batchSize+              .~ 1+              & #backoff+              .~ ConstantBackoff 3600+      Right () <-+        Store.runStoreIO storeHandle $+          Store.runTransaction $+            traverse_ (uncurry enqueueIntegrationEventTx) rows+      Right failedPass <- Store.runStoreIO storeHandle (publishClaimedOutbox (perRow failA1) opts Nothing)+      failedPass ^. #retried `shouldBe` 1+      now <- getCurrentTime+      Right claimed <- Store.runStoreIO storeHandle (claimOutboxBatch PerKeyHeadOfLine 10 now)+      fmap (^. #outboxId) claimed `shouldBe` [b1Id, b2Id]+      Right (Just a2Row) <- Store.runStoreIO storeHandle (lookupOutbox a2Id)+      a2Row ^. #status `shouldBe` OutboxPending++    it "claims contiguous per-source runs in one pass" $ \storeHandle -> do+      let rows =+            [ (outboxIdFromOrdinal 1, sampleIntegrationEnvelope & #messageId .~ "source-a1" & #key .~ Just "A"),+              (outboxIdFromOrdinal 2, sampleIntegrationEnvelope & #messageId .~ "source-b1" & #key .~ Just "B"),+              (outboxIdFromOrdinal 3, sampleIntegrationEnvelope & #messageId .~ "source-a2" & #key .~ Just "A"),+              (outboxIdFromOrdinal 4, sampleIntegrationEnvelope & #messageId .~ "source-b2" & #key .~ Just "B")+            ]+      Right () <-+        Store.runStoreIO storeHandle $+          Store.runTransaction $+            traverse_ (uncurry enqueueIntegrationEventTx) rows+      now <- getCurrentTime+      Right claimed <- Store.runStoreIO storeHandle (claimOutboxBatch PerSourceStream 10 now)+      fmap (^. #outboxId) claimed `shouldBe` fmap fst rows++    it "claims null-keyed rows freely alongside keyed runs" $ \storeHandle -> do+      let rows =+            [ (outboxIdFromOrdinal 1, sampleIntegrationEnvelope & #messageId .~ "null-1" & #key .~ Nothing),+              (outboxIdFromOrdinal 2, sampleIntegrationEnvelope & #messageId .~ "keyed-1" & #key .~ Just "A"),+              (outboxIdFromOrdinal 3, sampleIntegrationEnvelope & #messageId .~ "null-2" & #key .~ Nothing),+              (outboxIdFromOrdinal 4, sampleIntegrationEnvelope & #messageId .~ "keyed-2" & #key .~ Just "A")+            ]+      Right () <-+        Store.runStoreIO storeHandle $+          Store.runTransaction $+            traverse_ (uncurry enqueueIntegrationEventTx) rows+      now <- getCurrentTime+      Right claimed <- Store.runStoreIO storeHandle (claimOutboxBatch PerKeyHeadOfLine 10 now)+      fmap (^. #outboxId) claimed `shouldBe` fmap fst rows++    it "does not claim a tail while the previous run is still publishing" $ \storeHandle -> do+      let rows =+            [ (outboxIdFromOrdinal 1, sampleIntegrationEnvelope & #messageId .~ "publishing-a1" & #key .~ Just "A"),+              (outboxIdFromOrdinal 2, sampleIntegrationEnvelope & #messageId .~ "publishing-a2" & #key .~ Just "A"),+              (outboxIdFromOrdinal 3, sampleIntegrationEnvelope & #messageId .~ "publishing-a3" & #key .~ Just "A")+            ]+      Right () <-+        Store.runStoreIO storeHandle $+          Store.runTransaction $+            traverse_ (uncurry enqueueIntegrationEventTx) rows+      now <- getCurrentTime+      Right firstClaim <- Store.runStoreIO storeHandle (claimOutboxBatch PerKeyHeadOfLine 10 now)+      fmap (^. #outboxId) firstClaim `shouldBe` fmap fst rows+      Right secondClaim <- Store.runStoreIO storeHandle (claimOutboxBatch PerKeyHeadOfLine 10 now)+      secondClaim `shouldBe` []++    it "marks a claimed row as sent with published_at set" $ \storeHandle -> do+      let oid = OutboxId outboxUuid1+      Right () <-+        Store.runStoreIO storeHandle $+          Store.runTransaction (enqueueIntegrationEventTx oid sampleIntegrationEnvelope)+      now <- getCurrentTime+      Right [_] <- Store.runStoreIO storeHandle (claimOutboxBatch PerKeyHeadOfLine 10 now)+      Right True <- Store.runStoreIO storeHandle (markOutboxSent oid now)+      Right (Just row) <- Store.runStoreIO storeHandle (lookupOutbox oid)+      row ^. #status `shouldBe` OutboxSent+      row ^. #publishedAt `shouldSatisfy` isJust+      row ^. #lastError `shouldBe` Nothing++    it "reclaims a row stranded in publishing by a crashed worker through maintenance" $ \storeHandle -> do+      let oid = OutboxId outboxUuid1+      Right () <-+        Store.runStoreIO storeHandle $+          Store.runTransaction (enqueueIntegrationEventTx oid sampleIntegrationEnvelope)+      now <- getCurrentTime+      let pastNow = addUTCTime (-3600) now+      Right [_] <- Store.runStoreIO storeHandle (claimOutboxBatch PerKeyHeadOfLine 10 now)+      Right () <- Store.runStoreIO storeHandle (backdateOutboxUpdatedAt oid pastNow)+      Right (Just stranded) <- Store.runStoreIO storeHandle (lookupOutbox oid)+      stranded ^. #status `shouldBe` OutboxPublishing+      publishedRef <- newIORef (0 :: Int)+      let publish _ = do+            liftIO (modifyIORef' publishedRef (+ 1))+            pure PublishSucceeded+      Right noPublish <- Store.runStoreIO storeHandle (publishClaimedOutbox (perRow publish) defaultPublishOptions Nothing)+      noPublish ^. #claimed `shouldBe` 0+      Right (Just stillStranded) <- Store.runStoreIO storeHandle (lookupOutbox oid)+      stillStranded ^. #status `shouldBe` OutboxPublishing+      Right maintenance <- Store.runStoreIO storeHandle (outboxMaintenancePass defaultMaintenanceOptions Nothing)+      maintenance ^. #requeued `shouldBe` 1+      maintenance ^. #deadLettered `shouldBe` 0+      Right summary <- Store.runStoreIO storeHandle (publishClaimedOutbox (perRow publish) defaultPublishOptions Nothing)+      summary ^. #published `shouldBe` 1+      published <- readIORef publishedRef+      published `shouldBe` 1+      Right (Just row) <- Store.runStoreIO storeHandle (lookupOutbox oid)+      row ^. #status `shouldBe` OutboxSent++    it "head-of-line traffic unwedges after reclaim" $ \storeHandle -> do+      let firstId = OutboxId outboxUuid1+          secondId = OutboxId outboxUuid2+          first = sampleIntegrationEnvelope & #messageId .~ "stuck-first" & #key .~ Just "same-key"+          second = sampleIntegrationEnvelope & #messageId .~ "stuck-second" & #key .~ Just "same-key"+      Right () <-+        Store.runStoreIO storeHandle $+          Store.runTransaction (enqueueIntegrationEventTx firstId first)+      Right () <-+        Store.runStoreIO storeHandle $+          Store.runTransaction (enqueueIntegrationEventTx secondId second)+      now <- getCurrentTime+      let pastNow = addUTCTime (-3600) now+      Right [claimedFirst] <- Store.runStoreIO storeHandle (claimOutboxBatch PerKeyHeadOfLine 1 now)+      claimedFirst ^. #outboxId `shouldBe` firstId+      Right () <- Store.runStoreIO storeHandle (backdateOutboxUpdatedAt firstId pastNow)+      publishedRef <- newIORef []+      let publish row = do+            liftIO (modifyIORef' publishedRef (<> [row ^. #outboxId]))+            pure PublishSucceeded+      Right maintenance <- Store.runStoreIO storeHandle (outboxMaintenancePass defaultMaintenanceOptions Nothing)+      maintenance ^. #requeued `shouldBe` 1+      Right firstPass <- Store.runStoreIO storeHandle (publishClaimedOutbox (perRow publish) defaultPublishOptions Nothing)+      firstPass ^. #published `shouldBe` 2+      Right secondPass <- Store.runStoreIO storeHandle (publishClaimedOutbox (perRow publish) defaultPublishOptions Nothing)+      secondPass ^. #published `shouldBe` 0+      published <- readIORef publishedRef+      published `shouldBe` [firstId, secondId]+      Right (Just secondRow) <- Store.runStoreIO storeHandle (lookupOutbox secondId)+      secondRow ^. #status `shouldBe` OutboxSent++    it "does not reclaim a recently claimed row" $ \storeHandle -> do+      let oid = OutboxId outboxUuid1+      Right () <-+        Store.runStoreIO storeHandle $+          Store.runTransaction (enqueueIntegrationEventTx oid sampleIntegrationEnvelope)+      now <- getCurrentTime+      Right [_] <- Store.runStoreIO storeHandle (claimOutboxBatch PerKeyHeadOfLine 10 now)+      publishedRef <- newIORef (0 :: Int)+      let publish _ = do+            liftIO (modifyIORef' publishedRef (+ 1))+            pure PublishSucceeded+      Right summary <- Store.runStoreIO storeHandle (publishClaimedOutbox (perRow publish) defaultPublishOptions Nothing)+      summary ^. #claimed `shouldBe` 0+      published <- readIORef publishedRef+      published `shouldBe` 0+      Right (Just row) <- Store.runStoreIO storeHandle (lookupOutbox oid)+      row ^. #status `shouldBe` OutboxPublishing++    it "a throwing batch publish callback fails every row in that publish call" $ \storeHandle -> do+      let throwId = OutboxId outboxUuid1+          okId = OutboxId outboxUuid2+          throwEvent = sampleIntegrationEnvelope & #messageId .~ "throwing-publish" & #key .~ Just "throw-key"+          okEvent = sampleIntegrationEnvelope & #messageId .~ "ok-after-throw" & #key .~ Just "ok-key"+      Right () <-+        Store.runStoreIO storeHandle $+          Store.runTransaction (enqueueIntegrationEventTx throwId throwEvent)+      Right () <-+        Store.runStoreIO storeHandle $+          Store.runTransaction (enqueueIntegrationEventTx okId okEvent)+      let publish row+            | row ^. #outboxId == throwId = liftIO (throwIO (userError "kafka exploded"))+            | otherwise = pure PublishSucceeded+      Right summary <-+        Store.runStoreIO storeHandle $+          publishClaimedOutbox (perRow publish) (defaultPublishOptions & #backoff .~ ConstantBackoff 0) Nothing+      summary ^. #retried `shouldBe` 2+      summary ^. #published `shouldBe` 0+      Right (Just throwRow) <- Store.runStoreIO storeHandle (lookupOutbox throwId)+      throwRow ^. #status `shouldBe` OutboxFailed+      throwRow ^. #lastError `shouldSatisfy` maybe False (Text.isInfixOf "kafka exploded")+      Right (Just okRow) <- Store.runStoreIO storeHandle (lookupOutbox okId)+      okRow ^. #status `shouldBe` OutboxFailed+      okRow ^. #lastError `shouldSatisfy` maybe False (Text.isInfixOf "kafka exploded")++    it "a row that exhausts attempts while crash-looping is dead-lettered by maintenance" $ \storeHandle -> do+      let oid = OutboxId outboxUuid1+          opts = defaultMaintenanceOptions & #maxAttempts .~ 1+      Right () <-+        Store.runStoreIO storeHandle $+          Store.runTransaction (enqueueIntegrationEventTx oid sampleIntegrationEnvelope)+      now <- getCurrentTime+      let pastNow = addUTCTime (-3600) now+      Right [_] <- Store.runStoreIO storeHandle (claimOutboxBatch PerKeyHeadOfLine 10 now)+      Right () <- Store.runStoreIO storeHandle (backdateOutboxUpdatedAt oid pastNow)+      Right summary <- Store.runStoreIO storeHandle (outboxMaintenancePass opts Nothing)+      summary ^. #requeued `shouldBe` 0+      summary ^. #deadLettered `shouldBe` 1+      Right (Just row) <- Store.runStoreIO storeHandle (lookupOutbox oid)+      row ^. #status `shouldBe` OutboxDead++    it "markOutboxSent does not resurrect a dead row" $ \storeHandle -> do+      let oid = OutboxId outboxUuid1+          opts = defaultPublishOptions & #maxAttempts .~ 1 & #backoff .~ ConstantBackoff 0+      Right () <-+        Store.runStoreIO storeHandle $+          Store.runTransaction (enqueueIntegrationEventTx oid sampleIntegrationEnvelope)+      let publish _ = pure (PublishFailed "boom")+      Right _ <- Store.runStoreIO storeHandle (publishClaimedOutbox (perRow publish) opts Nothing)+      now <- getCurrentTime+      Right marked <- Store.runStoreIO storeHandle (markOutboxSent oid now)+      marked `shouldBe` False+      Right (Just row) <- Store.runStoreIO storeHandle (lookupOutbox oid)+      row ^. #status `shouldBe` OutboxDead++    it "publishClaimedOutbox marks success and records failures with last_error" $ \storeHandle -> do+      let okId = OutboxId outboxUuid1+          failId = OutboxId outboxUuid2+          okEvent = sampleIntegrationEnvelope+          failEvent =+            sampleIntegrationEnvelope+              & #messageId+              .~ "msg-fail-1"+              & #key+              .~ Just "order-789"+      Right () <-+        Store.runStoreIO storeHandle $+          Store.runTransaction (enqueueIntegrationEventTx okId okEvent)+      Right () <-+        Store.runStoreIO storeHandle $+          Store.runTransaction (enqueueIntegrationEventTx failId failEvent)+      let publish row+            | row ^. #outboxId == okId = pure PublishSucceeded+            | otherwise = pure (PublishFailed "broker unreachable")+      Right summary <-+        Store.runStoreIO storeHandle (publishClaimedOutbox (perRow publish) defaultPublishOptions Nothing)+      summary ^. #claimed `shouldBe` 2+      summary ^. #published `shouldBe` 1+      summary ^. #retried `shouldBe` 1+      summary ^. #dead `shouldBe` 0+      Right (Just okRow) <- Store.runStoreIO storeHandle (lookupOutbox okId)+      okRow ^. #status `shouldBe` OutboxSent+      Right (Just failRow) <- Store.runStoreIO storeHandle (lookupOutbox failId)+      failRow ^. #status `shouldBe` OutboxFailed+      failRow ^. #lastError `shouldBe` Just "broker unreachable"++    it "publishClaimedOutbox hands a same-key run to one batch publish call" $ \storeHandle -> do+      let rows =+            [ (outboxIdFromOrdinal (fromIntegral i), sampleIntegrationEnvelope & #messageId .~ ("batch-ok-" <> Text.pack (show i)) & #key .~ Just "batch-key")+            | i <- [1 .. 10 :: Int]+            ]+      Right () <-+        Store.runStoreIO storeHandle $+          Store.runTransaction $+            traverse_ (uncurry enqueueIntegrationEventTx) rows+      invocationRef <- newIORef (0 :: Int)+      let publish claimed = do+            liftIO (modifyIORef' invocationRef (+ 1))+            pure [(row ^. #outboxId, PublishSucceeded) | row <- claimed]+      Right summary <- Store.runStoreIO storeHandle (publishClaimedOutbox publish defaultPublishOptions Nothing)+      summary ^. #claimed `shouldBe` 10+      summary ^. #published `shouldBe` 10+      invocations <- readIORef invocationRef+      invocations `shouldBe` 1+      for_ (fmap fst rows) $ \oid -> do+        Right (Just row) <- Store.runStoreIO storeHandle (lookupOutbox oid)+        row ^. #status `shouldBe` OutboxSent++    it "publishClaimedOutbox skips the same-key suffix after a mid-run failure" $ \storeHandle -> do+      let row1Id = outboxIdFromOrdinal 1+          row2Id = outboxIdFromOrdinal 2+          row3Id = outboxIdFromOrdinal 3+          row4Id = outboxIdFromOrdinal 4+          row5Id = outboxIdFromOrdinal 5+          ids = [row1Id, row2Id, row3Id, row4Id, row5Id]+          rows =+            [ (oid, sampleIntegrationEnvelope & #messageId .~ ("batch-fail-" <> Text.pack (show i)) & #key .~ Just "batch-fail-key")+            | (i, oid) <- zip [1 .. 5 :: Int] ids+            ]+          publish claimed =+            pure+              [ ( row ^. #outboxId,+                  if row ^. #outboxId == row3Id+                    then PublishFailed "pivot failed"+                    else PublishSucceeded+                )+              | row <- claimed+              ]+      Right () <-+        Store.runStoreIO storeHandle $+          Store.runTransaction $+            traverse_ (uncurry enqueueIntegrationEventTx) rows+      Right summary <-+        Store.runStoreIO storeHandle $+          publishClaimedOutbox publish (defaultPublishOptions & #backoff .~ ConstantBackoff 0) Nothing+      summary ^. #published `shouldBe` 2+      summary ^. #retried `shouldBe` 3+      Right (Just row1) <- Store.runStoreIO storeHandle (lookupOutbox row1Id)+      Right (Just row2) <- Store.runStoreIO storeHandle (lookupOutbox row2Id)+      Right (Just row3) <- Store.runStoreIO storeHandle (lookupOutbox row3Id)+      Right (Just row4) <- Store.runStoreIO storeHandle (lookupOutbox row4Id)+      Right (Just row5) <- Store.runStoreIO storeHandle (lookupOutbox row5Id)+      row1 ^. #status `shouldBe` OutboxSent+      row2 ^. #status `shouldBe` OutboxSent+      row3 ^. #status `shouldBe` OutboxFailed+      row3 ^. #attemptCount `shouldBe` 1+      row3 ^. #lastError `shouldBe` Just "pivot failed"+      row4 ^. #status `shouldBe` OutboxFailed+      row4 ^. #attemptCount `shouldBe` 0+      row4 ^. #lastError `shouldBe` Just "skipped: earlier record for the same key failed"+      row5 ^. #status `shouldBe` OutboxFailed+      row5 ^. #attemptCount `shouldBe` 0++    it "PerSourceStream keeps one source's failure from skipping another source's rows" $ \storeHandle -> do+      let rowA1 = outboxIdFromOrdinal 1+          rowB1 = outboxIdFromOrdinal 2+          rowA2 = outboxIdFromOrdinal 3+          rowB2 = outboxIdFromOrdinal 4+          mkRow oid src msgId =+            (oid, sampleIntegrationEnvelope & #messageId .~ msgId & #source .~ src & #key .~ Nothing)+          rows =+            [ mkRow rowA1 "per-source-a" "ps-a1",+              mkRow rowB1 "per-source-b" "ps-b1",+              mkRow rowA2 "per-source-a" "ps-a2",+              mkRow rowB2 "per-source-b" "ps-b2"+            ]+          publish claimed =+            pure+              [ ( row ^. #outboxId,+                  if row ^. #outboxId == rowA2+                    then PublishFailed "source-a pivot failed"+                    else PublishSucceeded+                )+              | row <- claimed+              ]+      Right () <-+        Store.runStoreIO storeHandle $+          Store.runTransaction $+            traverse_ (uncurry enqueueIntegrationEventTx) rows+      Right summary <-+        Store.runStoreIO storeHandle $+          publishClaimedOutbox publish (defaultPublishOptions & #orderingPolicy .~ PerSourceStream & #backoff .~ ConstantBackoff 0) Nothing+      summary ^. #claimed `shouldBe` 4+      summary ^. #published `shouldBe` 3+      summary ^. #retried `shouldBe` 1+      Right (Just a1) <- Store.runStoreIO storeHandle (lookupOutbox rowA1)+      Right (Just a2) <- Store.runStoreIO storeHandle (lookupOutbox rowA2)+      Right (Just b1) <- Store.runStoreIO storeHandle (lookupOutbox rowB1)+      Right (Just b2) <- Store.runStoreIO storeHandle (lookupOutbox rowB2)+      a1 ^. #status `shouldBe` OutboxSent+      a2 ^. #status `shouldBe` OutboxFailed+      a2 ^. #attemptCount `shouldBe` 1+      a2 ^. #lastError `shouldBe` Just "source-a pivot failed"+      b1 ^. #status `shouldBe` OutboxSent+      b2 ^. #status `shouldBe` OutboxSent++    it "a late failure mark does not clobber a row that already reached a terminal state" $ \storeHandle -> do+      let oid = OutboxId outboxUuid1+      Right () <-+        Store.runStoreIO storeHandle $+          Store.runTransaction (enqueueIntegrationEventTx oid sampleIntegrationEnvelope)+      now <- getCurrentTime+      Right [_] <- Store.runStoreIO storeHandle (claimOutboxBatch PerKeyHeadOfLine 10 now)+      Right True <- Store.runStoreIO storeHandle (markOutboxSent oid now)+      Right _ <-+        Store.runStoreIO storeHandle $+          Store.runTransaction (markOutboxFailedTx oid "late failure from a timed-out worker" 5 60 now)+      Right (Just row) <- Store.runStoreIO storeHandle (lookupOutbox oid)+      row ^. #status `shouldBe` OutboxSent+      row ^. #lastError `shouldBe` Nothing++    it "claims nothing while another transaction holds an uncommitted claim on a key's head" $ \storeHandle -> do+      let headId = outboxIdFromOrdinal 1+          tailId = outboxIdFromOrdinal 2+          rows =+            [ (headId, sampleIntegrationEnvelope & #messageId .~ "claim-race-1" & #key .~ Just "claim-race-key"),+              (tailId, sampleIntegrationEnvelope & #messageId .~ "claim-race-2" & #key .~ Just "claim-race-key")+            ]+          OutboxId headUuid = headId+          holdClaimSql =+            TE.encodeUtf8 $+              "UPDATE keiro.keiro_outbox SET status = 'publishing', attempt_count = attempt_count + 1, updated_at = now() WHERE outbox_id = '"+                <> UUID.toText headUuid+                <> "'"+      Right () <-+        Store.runStoreIO storeHandle $+          Store.runTransaction $+            traverse_ (uncurry enqueueIntegrationEventTx) rows+      holderDone <- newEmptyMVar+      _ <- forkIO $ do+        holder <-+          Store.runStoreIO storeHandle $+            Store.runTransaction $ do+              Tx.sql holdClaimSql+              Tx.sql "SELECT pg_sleep(2)"+        putMVar holderDone holder+      -- Let the holder acquire its uncommitted row lock, then race a claim.+      threadDelay 500000+      now <- getCurrentTime+      Right claimed <- Store.runStoreIO storeHandle (claimOutboxBatch PerKeyHeadOfLine 10 now)+      fmap (^. #outboxId) claimed `shouldBe` []+      Right () <- takeMVar holderDone+      pure ()++    it "StopTheLine publishes singleton batches and skips the unattempted suffix" $ \storeHandle -> do+      let row1Id = outboxIdFromOrdinal 1+          row2Id = outboxIdFromOrdinal 2+          row3Id = outboxIdFromOrdinal 3+          row4Id = outboxIdFromOrdinal 4+          ids = [row1Id, row2Id, row3Id, row4Id]+          rows =+            [ (oid, sampleIntegrationEnvelope & #messageId .~ ("stop-line-" <> Text.pack (show i)) & #key .~ Just "stop-key")+            | (i, oid) <- zip [1 .. 4 :: Int] ids+            ]+          publishRef = fmap (^. #outboxId)+          publish claimed =+            pure+              [ ( row ^. #outboxId,+                  if row ^. #outboxId == row2Id+                    then PublishFailed "stop here"+                    else PublishSucceeded+                )+              | row <- claimed+              ]+      Right () <-+        Store.runStoreIO storeHandle $+          Store.runTransaction $+            traverse_ (uncurry enqueueIntegrationEventTx) rows+      seenRef <- newIORef []+      let trackedPublish claimed = do+            liftIO (modifyIORef' seenRef (<> publishRef claimed))+            publish claimed+          opts = defaultPublishOptions & #orderingPolicy .~ StopTheLine & #backoff .~ ConstantBackoff 0+      Right summary <- Store.runStoreIO storeHandle (publishClaimedOutbox trackedPublish opts Nothing)+      summary ^. #published `shouldBe` 1+      summary ^. #retried `shouldBe` 3+      summary ^. #haltedOn `shouldBe` Just row2Id+      seen <- readIORef seenRef+      seen `shouldBe` take 2 ids+      Right (Just row3) <- Store.runStoreIO storeHandle (lookupOutbox row3Id)+      Right (Just row4) <- Store.runStoreIO storeHandle (lookupOutbox row4Id)+      row3 ^. #status `shouldBe` OutboxFailed+      row3 ^. #attemptCount `shouldBe` 0+      row4 ^. #status `shouldBe` OutboxFailed+      row4 ^. #attemptCount `shouldBe` 0++    it "publishClaimedOutbox treats a missing batch outcome as a failed row" $ \storeHandle -> do+      let okId = outboxIdFromOrdinal 1+          missingId = outboxIdFromOrdinal 2+          okEvent = sampleIntegrationEnvelope & #messageId .~ "missing-outcome-ok" & #key .~ Just "ok-key"+          missingEvent = sampleIntegrationEnvelope & #messageId .~ "missing-outcome-fail" & #key .~ Just "missing-key"+          publish claimed =+            pure+              [ (row ^. #outboxId, PublishSucceeded)+              | row <- claimed,+                row ^. #outboxId == okId+              ]+      Right () <-+        Store.runStoreIO storeHandle $+          Store.runTransaction $ do+            enqueueIntegrationEventTx okId okEvent+            enqueueIntegrationEventTx missingId missingEvent+      Right summary <- Store.runStoreIO storeHandle (publishClaimedOutbox publish defaultPublishOptions Nothing)+      summary ^. #published `shouldBe` 1+      summary ^. #retried `shouldBe` 1+      Right (Just missingRow) <- Store.runStoreIO storeHandle (lookupOutbox missingId)+      missingRow ^. #status `shouldBe` OutboxFailed+      missingRow ^. #lastError `shouldBe` Just "publisher returned no outcome"++    it "auto-dead-letters a row after maxAttempts consecutive failures" $ \storeHandle -> do+      let oid = OutboxId outboxUuid1+          event = sampleIntegrationEnvelope & #key .~ Nothing+          opts =+            defaultPublishOptions+              & #batchSize+              .~ 10+              & #maxAttempts+              .~ 3+              & #backoff+              .~ ConstantBackoff 0+              & #orderingPolicy+              .~ BestEffort+      Right () <-+        Store.runStoreIO storeHandle $+          Store.runTransaction (enqueueIntegrationEventTx oid event)+      let publish _ = pure (PublishFailed "broker exploded")+      -- First two failures retain Failed status.+      Right s1 <- Store.runStoreIO storeHandle (publishClaimedOutbox (perRow publish) opts Nothing)+      s1 ^. #retried `shouldBe` 1+      s1 ^. #dead `shouldBe` 0+      Right s2 <- Store.runStoreIO storeHandle (publishClaimedOutbox (perRow publish) opts Nothing)+      s2 ^. #retried `shouldBe` 1+      s2 ^. #dead `shouldBe` 0+      -- Third failure crosses the threshold.+      Right s3 <- Store.runStoreIO storeHandle (publishClaimedOutbox (perRow publish) opts Nothing)+      s3 ^. #dead `shouldBe` 1+      Right (Just row) <- Store.runStoreIO storeHandle (lookupOutbox oid)+      row ^. #status `shouldBe` OutboxDead+      -- A dead row is not claimable.+      now <- getCurrentTime+      Right reclaimed <- Store.runStoreIO storeHandle (claimOutboxBatch BestEffort 10 now)+      reclaimed `shouldBe` []++    it "garbageCollectSent deletes only old sent rows" $ \storeHandle -> do+      let oldSentId = OutboxId outboxUuid1+          recentSentId = OutboxId outboxUuid2+          failedId = OutboxId outboxUuid3+          deadId = OutboxId outboxUuid4+          base = sampleIntegrationEnvelope & #key .~ Nothing+      Right () <-+        Store.runStoreIO storeHandle $+          Store.runTransaction (enqueueIntegrationEventTx oldSentId (base & #messageId .~ "gc-old-sent"))+      Right () <-+        Store.runStoreIO storeHandle $+          Store.runTransaction (enqueueIntegrationEventTx recentSentId (base & #messageId .~ "gc-recent-sent"))+      Right () <-+        Store.runStoreIO storeHandle $+          Store.runTransaction (enqueueIntegrationEventTx failedId (base & #messageId .~ "gc-failed"))+      let firstPass row+            | row ^. #outboxId == failedId = pure (PublishFailed "keep failed")+            | otherwise = pure PublishSucceeded+          firstPassOpts =+            defaultPublishOptions+              & #batchSize+              .~ 10+              & #orderingPolicy+              .~ BestEffort+              & #backoff+              .~ ConstantBackoff 3600+      Right _ <- Store.runStoreIO storeHandle (publishClaimedOutbox (perRow firstPass) firstPassOpts Nothing)+      Right () <-+        Store.runStoreIO storeHandle $+          Store.runTransaction (enqueueIntegrationEventTx deadId (base & #messageId .~ "gc-dead"))+      let deadPass row+            | row ^. #outboxId == deadId = pure (PublishFailed "keep dead")+            | otherwise = pure PublishSucceeded+          deadPassOpts =+            defaultPublishOptions+              & #batchSize+              .~ 10+              & #maxAttempts+              .~ 1+              & #orderingPolicy+              .~ BestEffort+      Right _ <- Store.runStoreIO storeHandle (publishClaimedOutbox (perRow deadPass) deadPassOpts Nothing)+      now <- getCurrentTime+      Right () <- Store.runStoreIO storeHandle (backdateOutboxPublishedAt oldSentId (addUTCTime (-3600) now))+      Right deleted <- Store.runStoreIO storeHandle (garbageCollectSent 300 now)+      deleted `shouldBe` 1+      Right oldRow <- Store.runStoreIO storeHandle (lookupOutbox oldSentId)+      oldRow `shouldBe` Nothing+      Right (Just recentRow) <- Store.runStoreIO storeHandle (lookupOutbox recentSentId)+      recentRow ^. #status `shouldBe` OutboxSent+      Right (Just failedRow) <- Store.runStoreIO storeHandle (lookupOutbox failedId)+      failedRow ^. #status `shouldBe` OutboxFailed+      Right (Just deadRow) <- Store.runStoreIO storeHandle (lookupOutbox deadId)+      deadRow ^. #status `shouldBe` OutboxDead++    it "enforces per-key head-of-line blocking and unblocks once the predecessor reaches a terminal state" $ \storeHandle -> do+      let a1Id = OutboxId outboxUuid1+          a2Id = OutboxId outboxUuid2+          b1Id = OutboxId outboxUuid3+          a1 = sampleIntegrationEnvelope & #messageId .~ "a1" & #key .~ Just "k1"+          a2 = sampleIntegrationEnvelope & #messageId .~ "a2" & #key .~ Just "k1"+          b1 = sampleIntegrationEnvelope & #messageId .~ "b1" & #key .~ Just "k2"+      -- Insert in created_at order (a1 first, then a2, then b1).+      Right () <-+        Store.runStoreIO storeHandle $+          Store.runTransaction (enqueueIntegrationEventTx a1Id a1)+      Right () <-+        Store.runStoreIO storeHandle $+          Store.runTransaction (enqueueIntegrationEventTx a2Id a2)+      Right () <-+        Store.runStoreIO storeHandle $+          Store.runTransaction (enqueueIntegrationEventTx b1Id b1)+      claimed <- newIORef []+      let publish row = do+            liftIO (atomicModifyIORef' claimed (\xs -> ((row ^. #outboxId) : xs, ())))+            if row ^. #outboxId == a1Id+              then pure (PublishFailed "broker hiccup")+              else pure PublishSucceeded+      -- First pass: with a one-row batch, a1 fails and both later rows remain pending.+      let firstPassOpts =+            defaultPublishOptions+              & #batchSize+              .~ 1+              & #backoff+              .~ ConstantBackoff 0+      Right summary1 <-+        Store.runStoreIO storeHandle (publishClaimedOutbox (perRow publish) firstPassOpts Nothing)+      summary1 ^. #claimed `shouldBe` 1+      claimedIds <- readIORef claimed+      claimedIds `shouldSatisfy` (a2Id `notElem`)+      claimedIds `shouldSatisfy` (a1Id `elem`)+      claimedIds `shouldSatisfy` (b1Id `notElem`)+      Right (Just a1Row) <- Store.runStoreIO storeHandle (lookupOutbox a1Id)+      a1Row ^. #status `shouldBe` OutboxFailed+      Right (Just b1Row) <- Store.runStoreIO storeHandle (lookupOutbox b1Id)+      b1Row ^. #status `shouldBe` OutboxPending+      Right (Just a2Row) <- Store.runStoreIO storeHandle (lookupOutbox a2Id)+      a2Row ^. #status `shouldBe` OutboxPending+      -- Drive a1 to terminal sent state so a2 can move. One pass claims a1+      -- (now that next_attempt_at has passed). A second pass claims a2,+      -- which becomes head-of-line once a1 reaches `sent`.+      writeIORef claimed []+      let publishOk row = do+            liftIO (atomicModifyIORef' claimed (\xs -> ((row ^. #outboxId) : xs, ())))+            pure PublishSucceeded+          retryOpts =+            defaultPublishOptions+              & #batchSize+              .~ 1+              & #backoff+              .~ ConstantBackoff 0+      Right _ <- Store.runStoreIO storeHandle (publishClaimedOutbox (perRow publishOk) retryOpts Nothing)+      Right _ <- Store.runStoreIO storeHandle (publishClaimedOutbox (perRow publishOk) retryOpts Nothing)+      Right _ <- Store.runStoreIO storeHandle (publishClaimedOutbox (perRow publishOk) retryOpts Nothing)+      claimedIds2 <- readIORef claimed+      claimedIds2 `shouldSatisfy` (a1Id `elem`)+      claimedIds2 `shouldSatisfy` (a2Id `elem`)+      claimedIds2 `shouldSatisfy` (b1Id `elem`)+      Right (Just a2Row') <- Store.runStoreIO storeHandle (lookupOutbox a2Id)+      a2Row' ^. #status `shouldBe` OutboxSent++    it "allows null-keyed rows to publish independently" $ \storeHandle -> do+      let n1 = OutboxId outboxUuid1+          n2 = OutboxId outboxUuid2+          e = sampleIntegrationEnvelope & #key .~ Nothing+      Right () <-+        Store.runStoreIO storeHandle $+          Store.runTransaction (enqueueIntegrationEventTx n1 (e & #messageId .~ "n1"))+      Right () <-+        Store.runStoreIO storeHandle $+          Store.runTransaction (enqueueIntegrationEventTx n2 (e & #messageId .~ "n2"))+      let publish row+            | row ^. #outboxId == n1 = pure (PublishFailed "transient")+            | otherwise = pure PublishSucceeded+      Right summary <-+        Store.runStoreIO storeHandle $+          publishClaimedOutbox (perRow publish) (defaultPublishOptions & #backoff .~ ConstantBackoff 0) Nothing+      summary ^. #claimed `shouldBe` 2+      summary ^. #published `shouldBe` 1+      summary ^. #retried `shouldBe` 1++    it "mints message ids with the configured TypeID prefix" $ \storeHandle -> do+      Right minted <-+        Store.runStoreIO storeHandle (mintIntegrationEvent sampleProducer sampleDraft)+      minted ^. #source `shouldBe` "ordering"+      minted ^. #destination `shouldBe` "billing.orders.v1"+      Text.isPrefixOf "msg_" (minted ^. #messageId) `shouldBe` True++    it "validates integration producer message id prefixes before startup" $ \_storeHandle -> do+      shouldBeRight_ (mkIntegrationProducer sampleProducer)+      case mkIntegrationProducer (sampleProducer & #messageIdPrefix .~ "Bad-Prefix") of+        Left (InvalidMessageIdPrefix prefix reason) -> do+          prefix `shouldBe` "Bad-Prefix"+          reason `shouldSatisfy` (not . Text.null)+        other -> expectationFailure ("expected invalid prefix, got " <> show (void other))++    it "draftToEvent stamps source and messageId without minting" $ \_storeHandle -> do+      let event = draftToEvent "ordering" "msg-fixed-1" sampleDraft+      event ^. #messageId `shouldBe` "msg-fixed-1"+      event ^. #source `shouldBe` "ordering"+      event ^. #destination `shouldBe` "billing.orders.v1"++    it "freshOutboxId returns distinct UUIDv7 ids" $ \storeHandle -> do+      Right ids <-+        Store.runStoreIO storeHandle (traverse (\_ -> freshOutboxId) [1 .. 4 :: Int])+      length ids `shouldBe` 4+      length (uniqueIds ids) `shouldBe` 4++    it "publishClaimedOutbox emits a Producer span with messaging semconv attributes" $ \storeHandle -> do+      (processor, spansRef) <- inMemoryListExporter+      provider <- createTracerProvider [processor] emptyTracerProviderOptions+      let tracer = makeTracer provider "keiro-test" tracerOptions+          okId = OutboxId outboxUuid1+          failId = OutboxId outboxUuid2+          okEvent = sampleIntegrationEnvelope+          failEvent =+            sampleIntegrationEnvelope+              & #messageId+              .~ "msg-fail-otel-1"+              & #key+              .~ Just "order-otel-fail"+      Right () <-+        Store.runStoreIO storeHandle $+          Store.runTransaction (enqueueIntegrationEventTx okId okEvent)+      Right () <-+        Store.runStoreIO storeHandle $+          Store.runTransaction (enqueueIntegrationEventTx failId failEvent)+      let publish row+            | row ^. #outboxId == okId = pure PublishSucceeded+            | otherwise = pure (PublishFailed "broker unreachable")+          opts = defaultPublishOptions & #tracer ?~ tracer+      Right _ <- Store.runStoreIO storeHandle (publishClaimedOutbox (perRow publish) opts Nothing)+      _ <- shutdownTracerProvider provider Nothing+      spans <- traverse captureSpan =<< readIORef spansRef+      length spans `shouldBe` 1+      case spans of+        [batchSpan] -> do+          csName batchSpan `shouldBe` ("send " <> (okEvent ^. #destination))+          show (csKind batchSpan) `shouldBe` "Producer"+          textAttr (csAttributes batchSpan) "messaging.system" `shouldBe` Just "kafka"+          textAttr (csAttributes batchSpan) "messaging.operation.type" `shouldBe` Just "publish"+          textAttr (csAttributes batchSpan) "messaging.operation.name" `shouldBe` Just "send"+          textAttr (csAttributes batchSpan) "messaging.destination.name"+            `shouldBe` Just (okEvent ^. #destination)+          textAttr (csAttributes batchSpan) "messaging.kafka.message.key"+            `shouldBe` (okEvent ^. #key)+          intAttr (csAttributes batchSpan) "keiro.outbox.batch.size" `shouldBe` Just 2+          textAttr (csAttributes batchSpan) "error.type" `shouldBe` Just "publish_failed"+          case csStatus batchSpan of+            Error msg -> msg `shouldBe` "broker unreachable"+            other -> expectationFailure ("expected Error \"broker unreachable\", got " <> show other)+        other -> expectationFailure ("expected one batch span, got " <> show (length other))++    it "publishClaimedOutbox records counters and sampleOutboxBacklog records the gauge" $ \storeHandle -> do+      (exporter, metricsRef) <- inMemoryMetricExporter+      (provider, _env) <-+        createMeterProvider+          emptyMaterializedResources+          defaultSdkMeterProviderOptions {metricExporter = Just exporter}+      meter <- getMeter provider Telemetry.keiroInstrumentationLibrary+      keiroMetrics <- Telemetry.newKeiroMetrics meter+      let okId = OutboxId outboxUuid1+          failId = OutboxId outboxUuid2+          okEvent = sampleIntegrationEnvelope & #messageId .~ "metrics-ok" & #key .~ Nothing+          failEvent = sampleIntegrationEnvelope & #messageId .~ "metrics-fail" & #key .~ Nothing+      Right () <-+        Store.runStoreIO storeHandle $+          Store.runTransaction (enqueueIntegrationEventTx okId okEvent)+      Right () <-+        Store.runStoreIO storeHandle $+          Store.runTransaction (enqueueIntegrationEventTx failId failEvent)+      let publish row+            | row ^. #outboxId == okId = pure PublishSucceeded+            | otherwise = pure (PublishFailed "broker down")+          retryPassOpts =+            defaultPublishOptions+              & #batchSize+              .~ 10+              & #maxAttempts+              .~ 5+              & #backoff+              .~ ConstantBackoff 0+              & #orderingPolicy+              .~ BestEffort+          deadPassOpts = retryPassOpts & #maxAttempts .~ 1+      -- Pass 1 (maxAttempts = 5): ok publishes, the fail row retries.+      Right summary1 <-+        Store.runStoreIO storeHandle (publishClaimedOutbox (perRow publish) retryPassOpts (Just keiroMetrics))+      summary1 ^. #published `shouldBe` 1+      summary1 ^. #retried `shouldBe` 1+      -- Pass 2 (maxAttempts = 1): the failed row crosses the ceiling and dies.+      Right summary2 <-+        Store.runStoreIO storeHandle (publishClaimedOutbox (perRow publish) deadPassOpts (Just keiroMetrics))+      summary2 ^. #dead `shouldBe` 1+      -- Flush so the in-memory exporter receives the aggregates.+      _ <- forceFlushMeterProvider provider Nothing+      exported <- readIORef metricsRef+      let scalars = flattenScalarPoints exported+      -- Counters are cumulative across both passes.+      lookup "keiro.outbox.published" scalars `shouldBe` Just (IntNumber 1)+      lookup "keiro.outbox.retried" scalars `shouldBe` Just (IntNumber 1)+      lookup "keiro.outbox.deadlettered" scalars `shouldBe` Just (IntNumber 1)+      -- Publish passes no longer run the backlog COUNT(*) on the hot path.+      lookup "keiro.outbox.backlog" scalars `shouldBe` Nothing++      Store.runStoreIO storeHandle (sampleOutboxBacklog (Just keiroMetrics)) `shouldReturn` Right ()+      _ <- forceFlushMeterProvider provider Nothing+      sampled <- readIORef metricsRef+      let sampledScalars = flattenScalarPoints sampled+      lookup "keiro.outbox.backlog" sampledScalars `shouldBe` Just (IntNumber 0)++  describe "Keiro.Inbox" $ around (withFreshStore fixture) $ do+    it "runs the handler once and records the row as completed" $ \storeHandle -> do+      Right () <-+        Store.runStoreIO storeHandle $+          Store.runTransaction (Tx.sql "CREATE TABLE IF NOT EXISTS inbox_test_counter (message_id TEXT PRIMARY KEY)")+      let event =+            sampleIntegrationEnvelope+              & #messageId+              .~ "inbox-msg-1"+              & #source+              .~ "ordering"+          handler ev =+            Tx.statement (ev ^. #messageId) inboxTestCounterInsertStmt+      Right result1 <-+        Store.runStoreIO storeHandle $+          runInboxTransaction Nothing PreferIntegrationMessageId event Nothing handler+      case result1 of+        Right (InboxProcessed ()) -> pure ()+        other -> expectationFailure ("expected InboxProcessed, got " <> show other)+      Right rowCount1 <-+        Store.runStoreIO storeHandle $+          Store.runTransaction (Tx.statement () inboxTestCounterCountStmt)+      rowCount1 `shouldBe` 1+      Right (Just inboxRow) <- Store.runStoreIO storeHandle (lookupInbox "ordering" "inbox-msg-1")+      inboxRow ^. #status `shouldBe` InboxCompleted+      inboxRow ^. #completedAt `shouldSatisfy` isJust++    it "treats a redelivery with the same messageId as a duplicate" $ \storeHandle -> do+      Right () <-+        Store.runStoreIO storeHandle $+          Store.runTransaction (Tx.sql "CREATE TABLE IF NOT EXISTS inbox_test_counter (message_id TEXT PRIMARY KEY)")+      let event =+            sampleIntegrationEnvelope+              & #messageId+              .~ "inbox-msg-dup"+              & #source+              .~ "ordering"+          handler ev = Tx.statement (ev ^. #messageId) inboxTestCounterInsertStmt+      Right (Right (InboxProcessed ())) <-+        Store.runStoreIO storeHandle $+          runInboxTransaction Nothing PreferIntegrationMessageId event Nothing handler+      Right result2 <-+        Store.runStoreIO storeHandle $+          runInboxTransaction Nothing PreferIntegrationMessageId event Nothing handler+      result2 `shouldBe` Right InboxDuplicate+      Right rowCount <-+        Store.runStoreIO storeHandle $+          Store.runTransaction (Tx.statement () inboxTestCounterCountStmt)+      rowCount `shouldBe` 1++    it "records inbox counters and samples backlog separately under the in-memory exporter" $ \storeHandle -> do+      (exporter, metricsRef) <- inMemoryMetricExporter+      (provider, _env) <-+        createMeterProvider+          emptyMaterializedResources+          defaultSdkMeterProviderOptions {metricExporter = Just exporter}+      meter <- getMeter provider Telemetry.keiroInstrumentationLibrary+      keiroMetrics <- Telemetry.newKeiroMetrics meter+      Right () <-+        Store.runStoreIO storeHandle $+          Store.runTransaction (Tx.sql "CREATE TABLE IF NOT EXISTS inbox_test_counter (message_id TEXT PRIMARY KEY)")+      let event = sampleIntegrationEnvelope & #messageId .~ "inbox-metrics-dup" & #source .~ "ordering"+          handler ev = Tx.statement (ev ^. #messageId) inboxTestCounterInsertStmt+      -- First delivery runs the handler: processed.+      Right (Right (InboxProcessed ())) <-+        Store.runStoreIO storeHandle $+          runInboxTransaction (Just keiroMetrics) PreferIntegrationMessageId event Nothing handler+      -- Second delivery of the same (source, message_id): duplicate.+      Right result2 <-+        Store.runStoreIO storeHandle $+          runInboxTransaction (Just keiroMetrics) PreferIntegrationMessageId event Nothing handler+      result2 `shouldBe` Right InboxDuplicate+      _ <- forceFlushMeterProvider provider Nothing+      exported <- readIORef metricsRef+      let scalars = flattenScalarPoints exported+      lookup "keiro.inbox.processed" scalars `shouldBe` Just (IntNumber 1)+      lookup "keiro.inbox.duplicates" scalars `shouldBe` Just (IntNumber 1)+      lookup "keiro.inbox.backlog" scalars `shouldBe` Nothing+      Store.runStoreIO storeHandle (sampleInboxBacklog (Just keiroMetrics)) `shouldReturn` Right ()+      _ <- forceFlushMeterProvider provider Nothing+      sampled <- readIORef metricsRef+      let sampledScalars = flattenScalarPoints sampled+      lookup "keiro.inbox.backlog" sampledScalars `shouldBe` Just (IntNumber 0)+      -- The handler ran exactly once (the duplicate path does not re-run it).+      Right rowCount <-+        Store.runStoreIO storeHandle $+          Store.runTransaction (Tx.statement () inboxTestCounterCountStmt)+      rowCount `shouldBe` 1++    it "deduplicates via PreferSourceEventIdentity even when messageId differs" $ \storeHandle -> do+      Right () <-+        Store.runStoreIO storeHandle $+          Store.runTransaction (Tx.sql "CREATE TABLE IF NOT EXISTS inbox_test_counter (message_id TEXT PRIMARY KEY)")+      let shared = sampleIntegrationEnvelope & #source .~ "ordering"+          first = shared & #messageId .~ "republish-1"+          second = shared & #messageId .~ "republish-2"+          handler ev = Tx.statement (ev ^. #messageId) inboxTestCounterInsertStmt+      Right (Right (InboxProcessed ())) <-+        Store.runStoreIO storeHandle $+          runInboxTransaction Nothing PreferSourceEventIdentity first Nothing handler+      Right result2 <-+        Store.runStoreIO storeHandle $+          runInboxTransaction Nothing PreferSourceEventIdentity second Nothing handler+      result2 `shouldBe` Right InboxDuplicate++    it "uses KafkaDeliveryIdentity when supplied" $ \storeHandle -> do+      Right () <-+        Store.runStoreIO storeHandle $+          Store.runTransaction (Tx.sql "CREATE TABLE IF NOT EXISTS inbox_test_counter (message_id TEXT PRIMARY KEY)")+      let event = sampleIntegrationEnvelope & #source .~ "ordering"+          kafka = KafkaDeliveryRef "billing.orders.v1" 0 17+          handler ev = Tx.statement (ev ^. #messageId) inboxTestCounterInsertStmt+      Right (Right (InboxProcessed ())) <-+        Store.runStoreIO storeHandle $+          runInboxTransaction Nothing KafkaDeliveryIdentity event (Just kafka) handler+      Right (Right InboxDuplicate) <-+        Store.runStoreIO storeHandle $+          runInboxTransaction Nothing KafkaDeliveryIdentity event (Just kafka) handler+      Right (Just row) <-+        Store.runStoreIO storeHandle $+          lookupInbox "ordering" "billing.orders.v1:0:17"+      row ^. #status `shouldBe` InboxCompleted++    it "reports DedupePolicyUnsatisfied when the envelope lacks the required field" $ \storeHandle -> do+      let event =+            sampleIntegrationEnvelope+              & #source+              .~ "ordering"+              & #sourceEventId+              .~ Nothing+              & #sourceGlobalPosition+              .~ Nothing+      Right result <-+        Store.runStoreIO storeHandle $+          runInboxTransaction Nothing PreferSourceEventIdentity event Nothing (\_ -> pure ())+      result `shouldBe` Left (DedupePolicyUnsatisfied PreferSourceEventIdentity)++    it "leaves no inbox row when the handler condemns the transaction" $ \storeHandle -> do+      let event =+            sampleIntegrationEnvelope+              & #messageId+              .~ "inbox-msg-rollback"+              & #source+              .~ "ordering"+          handler _ = do+            Tx.condemn+            pure ()+      _ <-+        Store.runStoreIO storeHandle $+          runInboxTransaction Nothing PreferIntegrationMessageId event Nothing handler+      Right row <- Store.runStoreIO storeHandle (lookupInbox "ordering" "inbox-msg-rollback")+      row `shouldBe` Nothing++    it "leaves no inbox row when the plain handler throws" $ \storeHandle -> do+      let event =+            sampleIntegrationEnvelope+              & #messageId+              .~ "inbox-msg-throw-plain"+              & #source+              .~ "ordering"+          handler _ = (pure $! error "plain inbox handler failed") :: Tx.Transaction ()+      thrown <-+        try $+          Store.runStoreIO storeHandle $+            runInboxTransaction Nothing PreferIntegrationMessageId event Nothing handler+      case thrown of+        Left (_ :: SomeException) -> pure ()+        Right other -> expectationFailure ("expected handler exception, got " <> show (void other))+      Right row <- Store.runStoreIO storeHandle (lookupInbox "ordering" "inbox-msg-throw-plain")+      row `shouldBe` Nothing++    it "exports markFailedTx from the public inbox module and preserves explicit failure marks" $ \storeHandle -> do+      let event =+            sampleIntegrationEnvelope+              & #messageId+              .~ "inbox-msg-public-failed"+              & #source+              .~ "ordering"+          handler _ = do+            markFailedTx "ordering" "inbox-msg-public-failed" "operator failed" (event ^. #occurredAt)+            pure ()+      Right (Right (InboxProcessed ())) <-+        Store.runStoreIO storeHandle $+          runInboxTransaction Nothing PreferIntegrationMessageId event Nothing handler+      Right (Just row) <- Store.runStoreIO storeHandle (lookupInbox "ordering" "inbox-msg-public-failed")+      row ^. #status `shouldBe` InboxFailed+      row ^. #lastError `shouldBe` Just "operator failed"++    it "a throwing handler records a failed attempt instead of looping" $ \storeHandle -> do+      let event =+            sampleIntegrationEnvelope+              & #messageId+              .~ "inbox-msg-poison-1"+              & #source+              .~ "ordering"+          handler _ = (pure $! error "inbox exploded") :: Tx.Transaction ()+      Right result <-+        Store.runStoreIO storeHandle $+          runInboxTransactionWithRetries Nothing 3 PreferIntegrationMessageId event Nothing handler+      case result of+        Right (InboxHandlerFailed err attempts) -> do+          Text.isInfixOf "inbox exploded" err `shouldBe` True+          attempts `shouldBe` 1+        other -> expectationFailure ("expected InboxHandlerFailed, got " <> show other)+      Right (Just row) <- Store.runStoreIO storeHandle (lookupInbox "ordering" "inbox-msg-poison-1")+      row ^. #status `shouldBe` InboxFailed+      row ^. #attemptCount `shouldBe` 1+      row ^. #lastError `shouldSatisfy` maybe False (Text.isInfixOf "inbox exploded")++    it "a transient poison message succeeds on retry" $ \storeHandle -> do+      Right () <-+        Store.runStoreIO storeHandle $+          Store.runTransaction (Tx.sql "CREATE TABLE IF NOT EXISTS inbox_test_counter (message_id TEXT PRIMARY KEY)")+      let event =+            sampleIntegrationEnvelope+              & #messageId+              .~ "inbox-msg-poison-transient"+              & #source+              .~ "ordering"+          failOnce _ = (pure $! error "temporary inbox failure") :: Tx.Transaction ()+          succeeding ev = Tx.statement (ev ^. #messageId) inboxTestCounterInsertStmt+      Right result1 <-+        Store.runStoreIO storeHandle $+          runInboxTransactionWithRetries Nothing 3 PreferIntegrationMessageId event Nothing failOnce+      case result1 of+        Right (InboxHandlerFailed _ 1) -> pure ()+        other -> expectationFailure ("expected first failed attempt, got " <> show other)+      Right result2 <-+        Store.runStoreIO storeHandle $+          runInboxTransactionWithRetries Nothing 3 PreferIntegrationMessageId event Nothing succeeding+      result2 `shouldBe` Right (InboxProcessed ())+      Right (Just row) <- Store.runStoreIO storeHandle (lookupInbox "ordering" "inbox-msg-poison-transient")+      row ^. #status `shouldBe` InboxCompleted+      row ^. #attemptCount `shouldBe` 1+      Right rowCount <-+        Store.runStoreIO storeHandle $+          Store.runTransaction (Tx.statement () inboxTestCounterCountStmt)+      rowCount `shouldBe` 1++    it "an unrecoverable message dead-letters at the ceiling" $ \storeHandle -> do+      let event =+            sampleIntegrationEnvelope+              & #messageId+              .~ "inbox-msg-poison-dead"+              & #source+              .~ "ordering"+          handler _ = (pure $! error "always broken") :: Tx.Transaction ()+      Right result1 <-+        Store.runStoreIO storeHandle $+          runInboxTransactionWithRetries Nothing 2 PreferIntegrationMessageId event Nothing handler+      Right result2 <-+        Store.runStoreIO storeHandle $+          runInboxTransactionWithRetries Nothing 2 PreferIntegrationMessageId event Nothing handler+      Right result3 <-+        Store.runStoreIO storeHandle $+          runInboxTransactionWithRetries Nothing 2 PreferIntegrationMessageId event Nothing handler+      case (result1, result2, result3) of+        ( Right (InboxHandlerFailed _ 1),+          Right (InboxHandlerFailed _ 2),+          Right (InboxPreviouslyFailed _)+          ) -> pure ()+        other -> expectationFailure ("unexpected poison lifecycle: " <> show other)+      Right (Just row) <- Store.runStoreIO storeHandle (lookupInbox "ordering" "inbox-msg-poison-dead")+      row ^. #status `shouldBe` InboxFailed+      row ^. #attemptCount `shouldBe` 2++    it "processes a batch of distinct messages in one transaction" $ \storeHandle -> do+      Right () <-+        Store.runStoreIO storeHandle $+          Store.runTransaction (Tx.sql "CREATE TABLE IF NOT EXISTS inbox_test_counter (message_id TEXT PRIMARY KEY)")+      let events =+            [ sampleIntegrationEnvelope+                & #messageId+                .~ ("inbox-batch-msg-" <> Text.pack (show n))+                & #source+                .~ "batch-ordering"+            | n <- [1 .. 50 :: Int]+            ]+          handler ev = Tx.statement (ev ^. #messageId) inboxTestCounterInsertStmt+      Right results <-+        Store.runStoreIO storeHandle $+          runInboxTransactionBatch Nothing 3 PreferIntegrationMessageId PersistFullEnvelope ((,Nothing) <$> events) handler+      results `shouldBe` replicate 50 (Right (InboxProcessed ()))+      Right rowCount <-+        Store.runStoreIO storeHandle $+          Store.runTransaction (Tx.statement () inboxTestCounterCountStmt)+      rowCount `shouldBe` 50+      Right inboxRows <- Store.runStoreIO storeHandle (listInbox "batch-ordering")+      length inboxRows `shouldBe` 50+      all ((== InboxCompleted) . (^. #status)) inboxRows `shouldBe` True++    it "deduplicates repeated messages within one batch" $ \storeHandle -> do+      Right () <-+        Store.runStoreIO storeHandle $+          Store.runTransaction (Tx.sql "CREATE TABLE IF NOT EXISTS inbox_test_counter (message_id TEXT PRIMARY KEY)")+      let event =+            sampleIntegrationEnvelope+              & #messageId+              .~ "inbox-batch-dup"+              & #source+              .~ "batch-ordering"+          handler ev = Tx.statement (ev ^. #messageId) inboxTestCounterInsertStmt+      Right results <-+        Store.runStoreIO storeHandle $+          runInboxTransactionBatch Nothing 3 PreferIntegrationMessageId PersistFullEnvelope [(event, Nothing), (event, Nothing)] handler+      results `shouldBe` [Right (InboxProcessed ()), Right InboxDuplicate]+      Right rowCount <-+        Store.runStoreIO storeHandle $+          Store.runTransaction (Tx.statement () inboxTestCounterCountStmt)+      rowCount `shouldBe` 1++    it "falls back per message when one batch handler throws" $ \storeHandle -> do+      Right () <-+        Store.runStoreIO storeHandle $+          Store.runTransaction (Tx.sql "CREATE TABLE IF NOT EXISTS inbox_test_counter (message_id TEXT PRIMARY KEY)")+      let events =+            [ sampleIntegrationEnvelope+                & #messageId+                .~ ("inbox-batch-poison-" <> Text.pack (show n))+                & #source+                .~ "batch-ordering"+            | n <- [1 .. 5 :: Int]+            ]+          handler ev+            | ev ^. #messageId == "inbox-batch-poison-3" =+                (pure $! error "batch poison") :: Tx.Transaction ()+            | otherwise =+                Tx.statement (ev ^. #messageId) inboxTestCounterInsertStmt+      Right results <-+        Store.runStoreIO storeHandle $+          runInboxTransactionBatch Nothing 3 PreferIntegrationMessageId PersistFullEnvelope ((,Nothing) <$> events) handler+      case results of+        [ Right (InboxProcessed ()),+          Right (InboxProcessed ()),+          Right (InboxHandlerFailed err 1),+          Right (InboxProcessed ()),+          Right (InboxProcessed ())+          ] ->+            Text.isInfixOf "batch poison" err `shouldBe` True+        other -> expectationFailure ("unexpected batch fallback results: " <> show other)+      Right rowCount <-+        Store.runStoreIO storeHandle $+          Store.runTransaction (Tx.statement () inboxTestCounterCountStmt)+      rowCount `shouldBe` 4+      Right (Just row) <- Store.runStoreIO storeHandle (lookupInbox "batch-ordering" "inbox-batch-poison-3")+      row ^. #status `shouldBe` InboxFailed+      row ^. #attemptCount `shouldBe` 1+      row ^. #lastError `shouldSatisfy` maybe False (Text.isInfixOf "batch poison")++    it "reports duplicates across batch calls" $ \storeHandle -> do+      Right () <-+        Store.runStoreIO storeHandle $+          Store.runTransaction (Tx.sql "CREATE TABLE IF NOT EXISTS inbox_test_counter (message_id TEXT PRIMARY KEY)")+      let event =+            sampleIntegrationEnvelope+              & #messageId+              .~ "inbox-batch-existing-dup"+              & #source+              .~ "batch-ordering"+          handler ev = Tx.statement (ev ^. #messageId) inboxTestCounterInsertStmt+      Right first <-+        Store.runStoreIO storeHandle $+          runInboxTransactionBatch Nothing 3 PreferIntegrationMessageId PersistFullEnvelope [(event, Nothing)] handler+      first `shouldBe` [Right (InboxProcessed ())]+      Right second <-+        Store.runStoreIO storeHandle $+          runInboxTransactionBatch Nothing 3 PreferIntegrationMessageId PersistFullEnvelope [(event, Nothing)] handler+      second `shouldBe` [Right InboxDuplicate]+      Right rowCount <-+        Store.runStoreIO storeHandle $+          Store.runTransaction (Tx.statement () inboxTestCounterCountStmt)+      rowCount `shouldBe` 1++    it "falls back per message when one batch handler condemns the transaction" $ \storeHandle -> do+      Right () <-+        Store.runStoreIO storeHandle $+          Store.runTransaction (Tx.sql "CREATE TABLE IF NOT EXISTS inbox_test_counter (message_id TEXT PRIMARY KEY)")+      let events =+            [ sampleIntegrationEnvelope+                & #messageId+                .~ ("inbox-batch-condemn-" <> Text.pack (show n))+                & #source+                .~ "batch-ordering"+            | n <- [1 .. 3 :: Int]+            ]+          handler ev+            | ev ^. #messageId == "inbox-batch-condemn-2" = Tx.condemn+            | otherwise = Tx.statement (ev ^. #messageId) inboxTestCounterInsertStmt+      Right results <-+        Store.runStoreIO storeHandle $+          runInboxTransactionBatch Nothing 3 PreferIntegrationMessageId PersistFullEnvelope ((,Nothing) <$> events) handler+      -- The condemned single-message retry reports processed by the+      -- documented single-path contract; what matters is that the+      -- innocent batch mates actually committed.+      results `shouldBe` replicate 3 (Right (InboxProcessed ()))+      Right rowCount <-+        Store.runStoreIO storeHandle $+          Store.runTransaction (Tx.statement () inboxTestCounterCountStmt)+      rowCount `shouldBe` 2+      Right (Just mate1) <- Store.runStoreIO storeHandle (lookupInbox "batch-ordering" "inbox-batch-condemn-1")+      Right (Just mate3) <- Store.runStoreIO storeHandle (lookupInbox "batch-ordering" "inbox-batch-condemn-3")+      mate1 ^. #status `shouldBe` InboxCompleted+      mate3 ^. #status `shouldBe` InboxCompleted+      Right condemned <- Store.runStoreIO storeHandle (lookupInbox "batch-ordering" "inbox-batch-condemn-2")+      condemned `shouldBe` Nothing++    it "classifies a legacy processing row as InboxInProgress without running the handler" $ \storeHandle -> do+      Right () <-+        Store.runStoreIO storeHandle $+          Store.runTransaction (Tx.sql "CREATE TABLE IF NOT EXISTS inbox_test_counter (message_id TEXT PRIMARY KEY)")+      let event =+            sampleIntegrationEnvelope+              & #messageId+              .~ "inbox-legacy-processing"+              & #source+              .~ "ordering"+          handler ev = Tx.statement (ev ^. #messageId) inboxTestCounterInsertStmt+      Right () <-+        Store.runStoreIO storeHandle $+          Store.runTransaction $+            Tx.sql "INSERT INTO keiro.keiro_inbox (source, dedupe_key, content_type, payload_bytes, status) VALUES ('ordering', 'inbox-legacy-processing', 'application/json', ''::bytea, 'processing')"+      Right result <-+        Store.runStoreIO storeHandle $+          runInboxTransaction Nothing PreferIntegrationMessageId event Nothing handler+      result `shouldBe` Right InboxInProgress+      Right rowCount <-+        Store.runStoreIO storeHandle $+          Store.runTransaction (Tx.statement () inboxTestCounterCountStmt)+      rowCount `shouldBe` 0+      Right (Just row) <- Store.runStoreIO storeHandle (lookupInbox "ordering" "inbox-legacy-processing")+      row ^. #status `shouldBe` InboxProcessing++    it "runs the handler once when two workers race the same dedupe key" $ \storeHandle -> do+      Right () <-+        Store.runStoreIO storeHandle $+          Store.runTransaction (Tx.sql "CREATE TABLE IF NOT EXISTS inbox_test_counter (message_id TEXT PRIMARY KEY)")+      let event =+            sampleIntegrationEnvelope+              & #messageId+              .~ "inbox-race-dup"+              & #source+              .~ "ordering"+          slowHandler ev = do+            Tx.statement (ev ^. #messageId) inboxTestCounterInsertStmt+            Tx.sql "SELECT pg_sleep(1.5)"+          fastHandler ev = Tx.statement (ev ^. #messageId) inboxTestCounterInsertStmt+      firstDone <- newEmptyMVar+      _ <- forkIO $ do+        first <-+          Store.runStoreIO storeHandle $+            runInboxTransaction Nothing PreferIntegrationMessageId event Nothing slowHandler+        putMVar firstDone first+      -- Let the slow worker insert its uncommitted row, then race the+      -- same dedupe key: the second insert must block on the unique+      -- constraint until the first commits, then classify as duplicate.+      threadDelay 400000+      Right second <-+        Store.runStoreIO storeHandle $+          runInboxTransaction Nothing PreferIntegrationMessageId event Nothing fastHandler+      Right first <- takeMVar firstDone+      first `shouldBe` Right (InboxProcessed ())+      second `shouldBe` Right InboxDuplicate+      Right rowCount <-+        Store.runStoreIO storeHandle $+          Store.runTransaction (Tx.statement () inboxTestCounterCountStmt)+      rowCount `shouldBe` 1++    it "can persist only dedupe columns for successful rows" $ \storeHandle -> do+      let kafka = KafkaDeliveryRef "billing.orders.v1" 1 42+          event =+            sampleIntegrationEnvelope+              & #messageId+              .~ "inbox-slim-success"+              & #source+              .~ "ordering"+              & #payloadBytes+              .~ "full success payload"+              & #attributes+              ?~ object ["source" Aeson..= ("slim-test" :: Text)]+          handler _ = pure ()+      Right (Right (InboxProcessed ())) <-+        Store.runStoreIO storeHandle $+          runInboxTransactionWith Nothing PersistDedupeOnly PreferIntegrationMessageId event (Just kafka) handler+      Right (Just row) <- Store.runStoreIO storeHandle (lookupInbox "ordering" "inbox-slim-success")+      row ^. #event . #payloadBytes `shouldBe` ""+      row ^. #event . #attributes `shouldBe` Nothing+      row ^. #event . #traceContext `shouldBe` Nothing+      row ^. #event . #schemaReference `shouldBe` Nothing+      row ^. #event . #messageId `shouldBe` "inbox-slim-success"+      row ^. #event . #sourceEventId `shouldBe` event ^. #sourceEventId+      row ^. #event . #sourceGlobalPosition `shouldBe` event ^. #sourceGlobalPosition+      row ^. #event . #causationId `shouldBe` event ^. #causationId+      row ^. #event . #correlationId `shouldBe` event ^. #correlationId+      row ^. #event . #occurredAt `shouldBe` event ^. #occurredAt+      row ^. #kafka `shouldBe` Just kafka+      Right redelivery <-+        Store.runStoreIO storeHandle $+          runInboxTransactionWith Nothing PersistDedupeOnly PreferIntegrationMessageId event (Just kafka) handler+      redelivery `shouldBe` Right InboxDuplicate++    it "keeps full failed rows even when successful rows are dedupe-only" $ \storeHandle -> do+      let event =+            sampleIntegrationEnvelope+              & #messageId+              .~ "inbox-slim-failed"+              & #source+              .~ "ordering"+              & #payloadBytes+              .~ "full failed payload"+              & #attributes+              ?~ object ["source" Aeson..= ("failed-slim-test" :: Text)]+          handler _ = (pure $! error "slim failure") :: Tx.Transaction ()+      Right result <-+        Store.runStoreIO storeHandle $+          runInboxTransactionWithRetriesWith Nothing 3 PersistDedupeOnly PreferIntegrationMessageId event Nothing handler+      case result of+        Right (InboxHandlerFailed err 1) ->+          Text.isInfixOf "slim failure" err `shouldBe` True+        other -> expectationFailure ("expected InboxHandlerFailed, got " <> show other)+      Right (Just row) <- Store.runStoreIO storeHandle (lookupInbox "ordering" "inbox-slim-failed")+      row ^. #status `shouldBe` InboxFailed+      row ^. #event . #payloadBytes `shouldBe` event ^. #payloadBytes+      row ^. #event . #attributes `shouldBe` event ^. #attributes+      row ^. #event . #traceContext `shouldBe` event ^. #traceContext+      row ^. #event . #schemaReference `shouldBe` event ^. #schemaReference++    it "garbage-collects completed rows older than the retention window" $ \storeHandle -> do+      let event =+            sampleIntegrationEnvelope+              & #messageId+              .~ "inbox-msg-gc"+              & #source+              .~ "ordering"+          handler _ = pure ()+      Right (Right (InboxProcessed ())) <-+        Store.runStoreIO storeHandle $+          runInboxTransaction Nothing PreferIntegrationMessageId event Nothing handler+      -- Backdate the row so it falls outside the retention window.+      Right () <-+        Store.runStoreIO storeHandle $+          Store.runTransaction $+            Tx.sql+              "UPDATE keiro.keiro_inbox SET completed_at = now() - interval '40 days' WHERE message_id = 'inbox-msg-gc'"+      now <- getCurrentTime+      Right deleted <- Store.runStoreIO storeHandle (garbageCollectCompleted (nominalDays 30) now)+      deleted `shouldBe` 1+      Right rows <- Store.runStoreIO storeHandle (listInbox "ordering")+      rows `shouldBe` []++  describe "Keiro.Inbox.Kafka" $ do+    it "reconstructs an integration event from headers and payload" $ do+      let envelope = sampleIntegrationEnvelope+          headers = integrationHeaders envelope+          receivedAt = addUTCTime 60 (envelope ^. #occurredAt)+          record =+            InboxKafka.KafkaInboundRecord+              { topic = "billing.orders.v1",+                partition = 2,+                offset = 113,+                key = Just "order-123",+                payload = envelope ^. #payloadBytes,+                headers,+                receivedAt+              }+      case InboxKafka.integrationEventFromKafka record of+        Right (rebuilt, kafkaRef) -> do+          rebuilt ^. #messageId `shouldBe` envelope ^. #messageId+          rebuilt ^. #source `shouldBe` envelope ^. #source+          rebuilt ^. #destination `shouldBe` envelope ^. #destination+          rebuilt ^. #eventType `shouldBe` envelope ^. #eventType+          rebuilt ^. #schemaVersion `shouldBe` envelope ^. #schemaVersion+          rebuilt ^. #sourceEventId `shouldBe` envelope ^. #sourceEventId+          rebuilt ^. #sourceGlobalPosition `shouldBe` envelope ^. #sourceGlobalPosition+          rebuilt ^. #payloadBytes `shouldBe` envelope ^. #payloadBytes+          rebuilt ^. #occurredAt `shouldBe` envelope ^. #occurredAt+          rebuilt ^. #attributes `shouldBe` envelope ^. #attributes+          kafkaRef ^. #topic `shouldBe` "billing.orders.v1"+          kafkaRef ^. #partition `shouldBe` 2+          kafkaRef ^. #offset `shouldBe` 113+        Left err -> expectationFailure ("expected Right, got Left " <> show err)++    it "falls back to receivedAt when the occurredAt header is absent" $ do+      let envelope = sampleIntegrationEnvelope+          receivedAt = addUTCTime 60 (envelope ^. #occurredAt)+          headers = filter ((/= "keiro-occurred-at") . Prelude.fst) (integrationHeaders envelope)+          record =+            InboxKafka.KafkaInboundRecord+              { topic = "billing.orders.v1",+                partition = 2,+                offset = 113,+                key = Just "order-123",+                payload = envelope ^. #payloadBytes,+                headers,+                receivedAt+              }+      case InboxKafka.integrationEventFromKafka record of+        Right (rebuilt, _) -> rebuilt ^. #occurredAt `shouldBe` receivedAt+        Left err -> expectationFailure ("expected Right, got Left " <> show err)++    it "rejects malformed occurredAt headers" $ do+      let envelope = sampleIntegrationEnvelope+          headers = ("keiro-occurred-at", "not-a-time") : filter ((/= "keiro-occurred-at") . Prelude.fst) (integrationHeaders envelope)+          record =+            InboxKafka.KafkaInboundRecord+              { topic = "billing.orders.v1",+                partition = 2,+                offset = 113,+                key = Just "order-123",+                payload = envelope ^. #payloadBytes,+                headers,+                receivedAt = envelope ^. #occurredAt+              }+      InboxKafka.integrationEventFromKafka record+        `shouldBe` Left (InboxKafka.InvalidTimeHeader "keiro-occurred-at" "not-a-time")++    it "reports MissingHeader for an essential header" $ do+      let envelope = sampleIntegrationEnvelope+          headers = filter ((/= "keiro-message-id") . Prelude.fst) (integrationHeaders envelope)+          record =+            InboxKafka.KafkaInboundRecord+              { topic = "billing.orders.v1",+                partition = 0,+                offset = 0,+                key = Nothing,+                payload = envelope ^. #payloadBytes,+                headers,+                receivedAt = envelope ^. #occurredAt+              }+      InboxKafka.integrationEventFromKafka record+        `shouldBe` Left (InboxKafka.MissingHeader "keiro-message-id")++    it "withConsumerSpan parents the consumer span under an upstream producer span via W3C headers" $ do+      (processor, spansRef) <- inMemoryListExporter+      provider <- createTracerProvider [processor] emptyTracerProviderOptions+      let tracer = makeTracer provider "keiro-test" tracerOptions+          -- Clear the baked-in TraceContext on the sample so the only+          -- `traceparent` on the wire comes from the active producer+          -- span (via `injectTraceContext`).+          envelope = sampleIntegrationEnvelope & #traceContext .~ Nothing+          producerRecord = OutboxKafka.integrationEventToKafkaRecord envelope+      producerHeadersText <-+        Telemetry.withProducerSpan (Just tracer) envelope producerRecord $ \_ -> do+          let baseHeaders =+                [(TE.decodeUtf8 n, TE.decodeUtf8 v) | (n, v) <- producerRecord ^. #headers]+          Telemetry.injectTraceContext baseHeaders+      -- Build the inbound record the consumer would receive and open the+      -- consumer span around a no-op body.+      now <- getCurrentTime+      let inbound =+            InboxKafka.KafkaInboundRecord+              { topic = envelope ^. #destination,+                partition = 7,+                offset = 42,+                key = envelope ^. #key,+                payload = envelope ^. #payloadBytes,+                headers = producerHeadersText,+                receivedAt = now+              }+      Telemetry.withConsumerSpan (Just tracer) (Just "billing-cg") inbound (Just envelope) $ \_ ->+        pure ()+      _ <- shutdownTracerProvider provider Nothing+      spans <- traverse captureSpan =<< readIORef spansRef+      length spans `shouldBe` 2+      let findByName needle = case [s | s <- spans, csName s == needle] of+            (s : _) -> s+            [] -> error ("no span captured with name=" <> Text.unpack needle)+          producerSp = findByName ("send " <> envelope ^. #destination)+          consumerSp = findByName ("process " <> envelope ^. #destination)+      -- Same trace id end-to-end (cross-process parenting).+      traceId (csContext producerSp) `shouldBe` traceId (csContext consumerSp)+      -- Consumer's parent is the producer span.+      case csParent consumerSp of+        Nothing -> expectationFailure "consumer span has no parent"+        Just parent -> do+          parentCtx <- getSpanContext parent+          spanId parentCtx `shouldBe` spanId (csContext producerSp)+      -- Consumer span carries the expected attributes.+      show (csKind consumerSp) `shouldBe` "Consumer"+      textAttr (csAttributes consumerSp) "messaging.system" `shouldBe` Just "kafka"+      textAttr (csAttributes consumerSp) "messaging.operation.type" `shouldBe` Just "process"+      textAttr (csAttributes consumerSp) "messaging.destination.name"+        `shouldBe` Just (envelope ^. #destination)+      textAttr (csAttributes consumerSp) "messaging.destination.partition.id"+        `shouldBe` Just "7"+      textAttr (csAttributes consumerSp) "messaging.consumer.group.name"+        `shouldBe` Just "billing-cg"+      textAttr (csAttributes consumerSp) "messaging.message.id"+        `shouldBe` Just (envelope ^. #messageId)++  describe "Keiro cross-context Kafka integration" $ around (withFreshStores2 fixture) $ do+    it "publishes an Ordering integration event and runs the Billing handler exactly once across duplicate deliveries" $ \(ordering, billing) -> do+      Right () <-+        Store.runStoreIO billing $+          Store.runTransaction (Tx.sql "CREATE TABLE IF NOT EXISTS billing_received_orders (order_id TEXT PRIMARY KEY, quantity BIGINT NOT NULL)")+      topic <- newKafkaTopic+      -- Ordering side: enqueue an outbox row representing a published event.+      let orderingEvent = orderSubmittedEnvelope "order-aaa" 7 "msg-aaa"+          oid = OutboxId outboxUuid1+      Right () <-+        Store.runStoreIO ordering $+          Store.runTransaction (enqueueIntegrationEventTx oid orderingEvent)+      -- Run the publisher worker: push records to the in-process topic.+      Right pubSummary1 <-+        Store.runStoreIO ordering $+          publishClaimedOutbox (perRow (kafkaTopicPublish topic)) defaultPublishOptions Nothing+      pubSummary1 ^. #published `shouldBe` 1+      -- Billing side: consume from the topic.+      records1 <- drainKafkaTopic topic+      record1 <- case records1 of+        [r] -> pure r+        other -> expectationFailure ("expected 1 record, got " <> show (length other)) *> error "unreachable"+      Right consumed1 <-+        Store.runStoreIO billing $+          consumeAndApply record1 billingReactionHandler+      consumed1 `shouldBe` ConsumeApplied (InboxProcessed ())+      Right rowCount1 <-+        Store.runStoreIO billing $+          Store.runTransaction (Tx.statement () billingReceivedOrdersCountStmt)+      rowCount1 `shouldBe` 1++      -- Simulate Kafka redelivery: pretend the same Kafka record was+      -- delivered again at a different offset. The producer also retries+      -- (the outbox flips back to pending and the worker republishes).+      let redelivered = redeliverWithDifferentOffset record1+      Right consumed2 <-+        Store.runStoreIO billing $+          consumeAndApply redelivered billingReactionHandler+      consumed2 `shouldBe` ConsumeApplied InboxDuplicate+      Right rowCount2 <-+        Store.runStoreIO billing $+          Store.runTransaction (Tx.statement () billingReceivedOrdersCountStmt)+      rowCount2 `shouldBe` 1++    it "preserves per-partition ordering for two events sharing a Kafka key" $ \(ordering, billing) -> do+      Right () <-+        Store.runStoreIO billing $+          Store.runTransaction (Tx.sql "CREATE TABLE IF NOT EXISTS billing_received_orders (order_id TEXT PRIMARY KEY, quantity BIGINT NOT NULL)")+      Right () <-+        Store.runStoreIO billing $+          Store.runTransaction (Tx.sql "CREATE TABLE IF NOT EXISTS billing_event_log (seq BIGSERIAL PRIMARY KEY, source TEXT NOT NULL, event_type TEXT NOT NULL, order_id TEXT NOT NULL)")+      topic <- newKafkaTopic+      -- Two events for the same order key.+      let submittedEnv = orderSubmittedEnvelope "order-bbb" 4 "msg-bbb-1"+          cancelledEnv = orderCancelledEnvelope "order-bbb" "msg-bbb-2"+          submittedId = OutboxId outboxUuid1+          cancelledId = OutboxId outboxUuid2+      Right () <-+        Store.runStoreIO ordering $+          Store.runTransaction (enqueueIntegrationEventTx submittedId submittedEnv)+      Right () <-+        Store.runStoreIO ordering $+          Store.runTransaction (enqueueIntegrationEventTx cancelledId cancelledEnv)+      -- Run-claiming lets a same-key contiguous run drain in one pass.+      let drainOnce =+            publishClaimedOutbox+              (perRow (kafkaTopicPublish topic))+              (defaultPublishOptions & #backoff .~ ConstantBackoff 0)+              Nothing+      Right s1 <- Store.runStoreIO ordering drainOnce+      Right s2 <- Store.runStoreIO ordering drainOnce+      (s1 ^. #published) + (s2 ^. #published) `shouldBe` 2+      records <- drainKafkaTopic topic+      length records `shouldBe` 2+      -- Apply both records to billing in delivery order.+      for_ records $ \record -> do+        Right consumed <-+          Store.runStoreIO billing $+            consumeAndApply record (loggingReactionHandler "billing")+        case consumed of+          ConsumeApplied (InboxProcessed ()) -> pure ()+          other -> expectationFailure ("expected processed, got " <> show other)+      Right events <-+        Store.runStoreIO billing $+          Store.runTransaction (Tx.statement () billingEventLogStmt)+      events `shouldBe` [("OrderSubmitted", "order-bbb"), ("OrderCancelled", "order-bbb")]++    it "head-of-line blocks a same-key successor when the first send fails repeatedly until the first row reaches dead status" $ \(ordering, billing) -> do+      Right () <-+        Store.runStoreIO billing $+          Store.runTransaction (Tx.sql "CREATE TABLE IF NOT EXISTS billing_received_orders (order_id TEXT PRIMARY KEY, quantity BIGINT NOT NULL)")+      topic <- newKafkaTopic+      let submittedEnv = orderSubmittedEnvelope "order-ccc" 1 "msg-ccc-1"+          cancelledEnv = orderCancelledEnvelope "order-ccc" "msg-ccc-2"+          firstId = OutboxId outboxUuid1+          secondId = OutboxId outboxUuid2+      Right () <-+        Store.runStoreIO ordering $+          Store.runTransaction (enqueueIntegrationEventTx firstId submittedEnv)+      Right () <-+        Store.runStoreIO ordering $+          Store.runTransaction (enqueueIntegrationEventTx secondId cancelledEnv)+      -- Failing publish for the first row, success for any other.+      let publish row+            | row ^. #outboxId == firstId =+                pure (PublishFailed "simulated broker reject")+            | otherwise = do+                kafkaTopicAccept topic row+                pure PublishSucceeded+          deadOpts =+            defaultPublishOptions+              & #batchSize+              .~ 1+              & #backoff+              .~ ConstantBackoff 0+              & #maxAttempts+              .~ 2+      -- This test drives the pre-M3 sequential failure/dead-letter path+      -- with one-row batches. M3 adds suffix skipping for larger claimed+      -- same-key runs.+      -- First pass: the first row attempts once and fails; the second is+      -- outside the one-row claim window.+      Right pass1 <- Store.runStoreIO ordering (publishClaimedOutbox (perRow publish) deadOpts Nothing)+      pass1 ^. #retried `shouldBe` 1+      pass1 ^. #published `shouldBe` 0+      -- Second pass crosses maxAttempts and dead-letters the first row.+      Right pass2 <- Store.runStoreIO ordering (publishClaimedOutbox (perRow publish) deadOpts Nothing)+      pass2 ^. #dead `shouldBe` 1+      Right (Just firstRow) <- Store.runStoreIO ordering (lookupOutbox firstId)+      firstRow ^. #status `shouldBe` OutboxDead+      -- With the first row dead, the second becomes claimable and publishes.+      Right pass3 <- Store.runStoreIO ordering (publishClaimedOutbox (perRow publish) deadOpts Nothing)+      pass3 ^. #published `shouldBe` 1+      Right (Just secondRow) <- Store.runStoreIO ordering (lookupOutbox secondId)+      secondRow ^. #status `shouldBe` OutboxSent+      -- Billing only sees the second event.+      records <- drainKafkaTopic topic+      record <- case records of+        [r] -> pure r+        other -> expectationFailure ("expected 1 record, got " <> show (length other)) *> error "unreachable"+      Right consumed <-+        Store.runStoreIO billing $+          consumeAndApply record billingReactionHandler+      consumed `shouldBe` ConsumeApplied (InboxProcessed ())++  describe "Keiro.Integration.Event" $ do+    it "round-trips a JSON envelope through encode and decode" $ do+      let envelope = sampleIntegrationEnvelope+          payload = OrderSubmittedPayload "order-123" 5+          encoded = encodeJsonIntegrationEvent envelope payload+      decodeJsonIntegrationEvent encoded `shouldBe` Right payload++    it "preserves identity and routing through encode" $ do+      let envelope = sampleIntegrationEnvelope+          encoded = encodeJsonIntegrationEvent envelope (OrderSubmittedPayload "order-123" 5)+      encoded ^. #messageId `shouldBe` envelope ^. #messageId+      encoded ^. #source `shouldBe` "ordering"+      encoded ^. #destination `shouldBe` "billing.orders.v1"+      encoded ^. #key `shouldBe` Just "order-123"+      encoded ^. #eventType `shouldBe` "OrderSubmitted"+      encoded ^. #schemaVersion `shouldBe` 1+      encoded ^. #contentType `shouldBe` ApplicationJson++    it "emits the canonical wire headers" $ do+      let envelope = sampleIntegrationEnvelope+          headers = integrationHeaders envelope+      Prelude.lookup headerMessageId headers `shouldBe` Just (envelope ^. #messageId)+      Prelude.lookup headerSchemaVersion headers `shouldBe` Just "1"+      Prelude.lookup headerContentType headers `shouldBe` Just "application/json"+      Prelude.lookup headerSchemaSubject headers `shouldBe` Just "billing.orders.v1.OrderSubmitted"+      Prelude.lookup headerSourceEventId headers `shouldBe` Just "018f0f18-17aa-7000-8000-000000000003"+      Prelude.lookup headerSourceGlobalPosition headers `shouldBe` Just "42"+      Prelude.lookup headerTraceParent headers+        `shouldBe` Just "00-0af7651916cd43dd8448eb211c80319c-b7ad6b7169203331-01"++    it "preserves a different content type without claiming JSON" $ do+      let envelope =+            sampleIntegrationEnvelope+              & #contentType+              .~ OtherContentType "application/vnd.apache.avro.binary"+              & #payloadBytes+              .~ "\x00\x01\x02"+          headers = integrationHeaders envelope+      Prelude.lookup headerContentType headers+        `shouldBe` Just "application/vnd.apache.avro.binary"+      decodeJsonIntegrationEvent envelope+        `shouldBe` ( Left (IntegrationEvent.UnsupportedContentType "application/vnd.apache.avro.binary") ::+                       Either IntegrationEvent.IntegrationEventError OrderSubmittedPayload+                   )++    it "reports malformed JSON payloads as decode errors instead of throwing" $ do+      let envelope =+            sampleIntegrationEnvelope+              & #payloadBytes+              .~ "{not-json"+      case decodeJsonIntegrationEvent envelope :: Either IntegrationEvent.IntegrationEventError OrderSubmittedPayload of+        Left (IntegrationEvent.MalformedPayload _) -> pure ()+        other -> expectationFailure ("expected MalformedPayload, got " <> show other)++    it "reports a JSON value that does not satisfy the target type as DecodeFailed" $ do+      let envelope =+            sampleIntegrationEnvelope+              & #payloadBytes+              .~ "{\"orderId\":\"order-123\"}"+      case decodeJsonIntegrationEvent envelope :: Either IntegrationEvent.IntegrationEventError OrderSubmittedPayload of+        Left (IntegrationEvent.DecodeFailed _) -> pure ()+        other -> expectationFailure ("expected DecodeFailed, got " <> show other)++    it "parses content-type headers back to the canonical type" $ do+      parseContentType "application/json" `shouldBe` ApplicationJson+      parseContentType "Application/JSON" `shouldBe` ApplicationJson+      parseContentType "application/json; charset=utf-8" `shouldBe` ApplicationJson+      parseContentType "APPLICATION/JSON ; CHARSET=UTF-8" `shouldBe` ApplicationJson+      parseContentType "application/vnd.apache.avro.binary"+        `shouldBe` OtherContentType "application/vnd.apache.avro.binary"++    it "preserves the payload bytes through integrationPayload" $ do+      let envelope = sampleIntegrationEnvelope+          encoded = encodeJsonIntegrationEvent envelope (OrderSubmittedPayload "order-123" 5)+      integrationPayload encoded `shouldBe` (encoded ^. #payloadBytes)++  describe "Keiro.Telemetry" $ do+    it "is a pass-through under a noop (Nothing) tracer" $ do+      counter <- newIORef (0 :: Int)+      let envelope = sampleIntegrationEnvelope+          record = OutboxKafka.integrationEventToKafkaRecord envelope+      result <-+        Telemetry.withProducerSpan Nothing envelope record $ \mSpan -> do+          atomicModifyIORef' counter (\n -> (n + 1, ()))+          pure (mSpan, "ok" :: Text)+      callsAfter <- readIORef counter+      callsAfter `shouldBe` (1 :: Int)+      snd result `shouldBe` "ok"+      fst result `shouldSatisfy` isNothing++    it "re-exports AttributeKeys whose textual payload matches the spec name" $ do+      attrKeyText Telemetry.messaging_operation_type `shouldBe` "messaging.operation.type"+      attrKeyText Telemetry.messaging_operation_name `shouldBe` "messaging.operation.name"+      attrKeyText Telemetry.messaging_destination_partition_id `shouldBe` "messaging.destination.partition.id"+      attrKeyText Telemetry.messaging_consumer_group_name `shouldBe` "messaging.consumer.group.name"+      attrKeyText Telemetry.messaging_client_id `shouldBe` "messaging.client.id"+      attrKeyTextInt64 Telemetry.messaging_kafka_offset `shouldBe` "messaging.kafka.offset"+      attrKeyText Telemetry.db_system_name `shouldBe` "db.system.name"+      attrKeyText Telemetry.db_namespace `shouldBe` "db.namespace"+      attrKeyText Telemetry.db_collection_name `shouldBe` "db.collection.name"+      attrKeyText Telemetry.db_operation_name `shouldBe` "db.operation.name"+      attrKeyText Telemetry.keiro_stream_name `shouldBe` "keiro.stream.name"+      attrKeyTextInt64 Telemetry.keiro_retry_attempt `shouldBe` "keiro.retry.attempt"+      attrKeyTextInt64 Telemetry.keiro_events_appended `shouldBe` "keiro.events.appended"+      attrKeyText Telemetry.keiro_replay_divergence `shouldBe` "keiro.replay.divergence"++    it "extracts a TraceContext from a W3C traceparent header pair" $ do+      let traceparent = "00-0af7651916cd43dd8448eb211c80319c-b7ad6b7169203331-01"+          tracestate = "vendor1=value1"+          hs = [(headerTraceParent, traceparent), ("tracestate", tracestate)]+      Telemetry.traceContextFromHeaders hs+        `shouldBe` Just (TraceContext traceparent (Just tracestate))++    it "returns Nothing when the traceparent header is missing" $ do+      Telemetry.traceContextFromHeaders [("content-type", "application/json")]+        `shouldBe` Nothing++    it "injectTraceContext is a no-op when no span is active on the thread" $ do+      let baseline = [("content-type", "application/json")]+      injected <- Telemetry.injectTraceContext baseline+      injected `shouldBe` baseline++    it "traceContextFromCurrentSpan returns Nothing outside any span" $ do+      tc <- Telemetry.traceContextFromCurrentSpan+      tc `shouldBe` Nothing++  describe "Keiro.Workflow" $ around (withFreshStore fixture) $ do+    it "journals each step once, returns Completed, and runs each side effect once" $ \storeHandle -> do+      counter <- newIORef (0 :: Int)+      let name = WorkflowName "demo"+          wid = WorkflowId "demo-1"+      result <- Store.runStoreIO storeHandle $ runWorkflow name wid (demoWorkflow counter)+      result `shouldBe` Right (Completed (1, 2))+      sideEffects <- readIORef counter+      sideEffects `shouldBe` 2+      Right recorded <-+        Store.runStoreIO storeHandle $+          Store.readStreamForward (StreamName "wf:demo-demo-1") (StreamVersion 0) 10+      Vector.length recorded `shouldBe` 3+      traverse (decodeRecorded workflowJournalCodec) (Vector.toList recorded)+        `shouldSatisfy` \case+          Right [StepRecorded "first" _ _, StepRecorded "second" _ _, WorkflowCompleted _] -> True+          _ -> False++    it "replays recorded steps without re-running their side effects" $ \storeHandle -> do+      counter <- newIORef (0 :: Int)+      let name = WorkflowName "replay"+          wid = WorkflowId "r-1"+      first <- Store.runStoreIO storeHandle $ runWorkflow name wid (demoWorkflow counter)+      first `shouldBe` Right (Completed (1, 2))+      afterFirst <- readIORef counter+      afterFirst `shouldBe` 2+      -- A second run with the same id is exactly the crash-restart scenario.+      second <- Store.runStoreIO storeHandle $ runWorkflow name wid (demoWorkflow counter)+      second `shouldBe` Right (Completed (1, 2))+      afterSecond <- readIORef counter+      afterSecond `shouldBe` 2+      -- The deterministic ids and pre-load gating leave the journal at 3 events.+      Right recorded <-+        Store.runStoreIO storeHandle $+          Store.readStreamForward (StreamName "wf:replay-r-1") (StreamVersion 0) 10+      Vector.length recorded `shouldBe` 3++    it "reuses the recorded result for a repeated step name in one run" $ \storeHandle -> do+      counter <- newIORef (0 :: Int)+      let name = WorkflowName "samename"+          wid = WorkflowId "s-1"+          duplicateStepWorkflow = do+            a <- step (StepName "dup") (liftIO (incrementAndRead counter))+            b <- step (StepName "dup") (liftIO (incrementAndRead counter))+            pure (a, b)+      result <- Store.runStoreIO storeHandle $ runWorkflow name wid duplicateStepWorkflow+      result `shouldBe` Right (Completed (1, 1))+      sideEffects <- readIORef counter+      sideEffects `shouldBe` 1++    it "suspends on an unresolved awaitStep, journaling no completion" $ \storeHandle -> do+      let name = WorkflowName "awaiter"+          wid = WorkflowId "a-1"+      result <- Store.runStoreIO storeHandle $ runWorkflow name wid neverArmingWorkflow+      result `shouldBe` Right Suspended+      Right recorded <-+        Store.runStoreIO storeHandle $+          Store.readStreamForward (StreamName "wf:awaiter-a-1") (StreamVersion 0) 10+      Vector.length recorded `shouldBe` 0++    it "resumes and completes once an awaited step is externally completed" $ \storeHandle -> do+      let name = WorkflowName "awaiter2"+          wid = WorkflowId "a-2"+      suspended <- Store.runStoreIO storeHandle $ runWorkflow name wid neverArmingWorkflow+      suspended `shouldBe` Right Suspended+      -- Simulate a wake source recording the awaited step's resolution.+      Right () <- Store.runStoreIO storeHandle $ do+        now <- liftIO getCurrentTime+        appendJournalEntry name wid (StepRecorded "awk:test" (toJSON (42 :: Int)) now)+      resumed <- Store.runStoreIO storeHandle $ runWorkflow name wid neverArmingWorkflow+      resumed `shouldBe` Right (Completed 42)+      Right recorded <-+        Store.runStoreIO storeHandle $+          Store.readStreamForward (StreamName "wf:awaiter2-a-2") (StreamVersion 0) 10+      traverse (decodeRecorded workflowJournalCodec) (Vector.toList recorded)+        `shouldSatisfy` \case+          Right [StepRecorded "awk:test" _ _, WorkflowCompleted _] -> True+          _ -> False++    it "treats a duplicate external journal append as idempotent" $ \storeHandle -> do+      let name = WorkflowName "duplicate-append"+          wid = WorkflowId "da-1"+          stepKey = "awk:test"+          eventAt t = StepRecorded stepKey (toJSON (42 :: Int)) t+      now <- getCurrentTime+      Right firstId <-+        Store.runStoreIO storeHandle $+          appendJournalEntryReturningId name wid (eventAt now)+      secondResult <-+        Store.runStoreIO storeHandle $+          appendJournalEntryReturningId name wid (eventAt now)+      secondId <- case secondResult of+        Right value -> pure value+        Left err -> expectationFailure ("expected idempotent duplicate append, got " <> show err) *> error "unreachable"+      secondId `shouldBe` firstId+      Right indexed <- Store.runStoreIO storeHandle $ loadStepIndex name wid 0+      Map.lookup stepKey indexed `shouldBe` Just (toJSON (42 :: Int))+      Right recorded <-+        Store.runStoreIO storeHandle $+          Store.readStreamForward (StreamName "wf:duplicate-append-da-1") (StreamVersion 0) 10+      Vector.length recorded `shouldBe` 1++    it "returns the journaled value when another writer records the same step mid-flight" $ \storeHandle -> do+      let name = WorkflowName "journal-race"+          wid = WorkflowId "jr-1"+          body =+            step (StepName "raced") $ do+              now <- liftIO getCurrentTime+              appendJournalEntry name wid (StepRecorded "raced" (toJSON ("winner" :: Text)) now)+              pure ("loser" :: Text)+      outcome <- Store.runStoreIO storeHandle $ runWorkflow name wid body+      outcome `shouldBe` Right (Completed "winner")+      Right recorded <-+        Store.runStoreIO storeHandle $+          Store.readStreamForward (StreamName "wf:journal-race-jr-1") (StreamVersion 0) 10+      traverse (decodeRecorded workflowJournalCodec) (Vector.toList recorded)+        `shouldSatisfy` \case+          Right [StepRecorded "raced" value _, WorkflowCompleted _] -> value == toJSON ("winner" :: Text)+          _ -> False++    it "returns the JSON round-trip of a fresh step result" $ \storeHandle -> do+      let name = WorkflowName "roundtrip-step"+          wid = WorkflowId "rs-1"+          body = step (StepName "approx") (pure (Approx 1.7))+      first <- Store.runStoreIO storeHandle $ runWorkflow name wid body+      first `shouldBe` Right (Completed (Approx 2.0))+      replay <- Store.runStoreIO storeHandle $ runWorkflow name wid body+      replay `shouldBe` Right (Completed (Approx 2.0))++    it "throws WorkflowStepDecodeError on the first run when the recorded result cannot decode" $ \storeHandle -> do+      let name = WorkflowName "bad-roundtrip"+          wid = WorkflowId "br-1"+          body = step (StepName "bad") (pure RejectingRoundTrip)+      Store.runStoreIO storeHandle (runWorkflow name wid body)+        `shouldThrow` \case+          WorkflowStepDecodeError key _ -> key == "bad"+          _ -> False+      Store.runStoreIO storeHandle (stepExists name wid 0 "bad")+        `shouldReturn` Right True++    it "discovers unfinished workflows via the step index" $ \storeHandle -> do+      counter <- newIORef (0 :: Int)+      Right (Completed _) <-+        Store.runStoreIO storeHandle $+          runWorkflow (WorkflowName "done") (WorkflowId "d-1") (demoWorkflow counter)+      Right Suspended <-+        Store.runStoreIO storeHandle $+          runWorkflow (WorkflowName "pending") (WorkflowId "p-1") (stepThenAwaitWorkflow counter)+      now <- getCurrentTime+      Right unfinished <- Store.runStoreIO storeHandle (findUnfinishedWorkflowIds now)+      unfinished `shouldBe` [("p-1", "pending")]++  describe "Keiro.Workflow instance table" $ around (withFreshStore fixture) $ do+    it "creates and completes a workflow instance row transactionally with the journal" $ \storeHandle -> do+      counter <- newIORef (0 :: Int)+      let name = WorkflowName "inst-complete"+          wid = WorkflowId "ic-1"+      Right (Completed _) <- Store.runStoreIO storeHandle $ runWorkflow name wid (demoWorkflow counter)+      Right (Just row) <- Store.runStoreIO storeHandle $ Instance.lookupInstance name wid+      row ^. #workflowId `shouldBe` "ic-1"+      row ^. #workflowName `shouldBe` "inst-complete"+      row ^. #generation `shouldBe` 0+      row ^. #status `shouldBe` Instance.WfCompleted+      row ^. #completedAt `shouldSatisfy` isJust++    it "records suspended status for workflows that park before journaling" $ \storeHandle -> do+      let name = WorkflowName "inst-suspended"+          wid = WorkflowId "is-1"+      Right Suspended <- Store.runStoreIO storeHandle $ runWorkflow name wid neverArmingWorkflow+      Right (Just row) <- Store.runStoreIO storeHandle $ Instance.lookupInstance name wid+      row ^. #status `shouldBe` Instance.WfSuspended+      row ^. #generation `shouldBe` 0+      row ^. #completedAt `shouldBe` Nothing++    it "creates child instance rows at spawn time and flips them to cancelled" $ \storeHandle -> do+      let childWid = WorkflowId "inst-child"+          childName = WorkflowName "ship"+      Right Suspended <-+        Store.runStoreIO storeHandle $+          runWorkflow (WorkflowName "inst-parent") (WorkflowId "ip-1") (parentWorkflow childWid)+      Right (Just spawned) <- Store.runStoreIO storeHandle $ Instance.lookupInstance childName childWid+      spawned ^. #status `shouldBe` Instance.WfRunning+      Right True <- Store.runStoreIO storeHandle $ cancelChild (ChildHandle childName childWid)+      Right (Just cancelledRow) <- Store.runStoreIO storeHandle $ Instance.lookupInstance childName childWid+      cancelledRow ^. #status `shouldBe` Instance.WfCancelled+      cancelledRow ^. #completedAt `shouldSatisfy` isJust++    it "bumps the instance generation when continueAsNew rotates" $ \storeHandle -> do+      counter <- newIORef (0 :: Int)+      let name = WorkflowName "inst-rotate"+          wid = WorkflowId "ir-1"+      Right ContinuedAsNew <-+        Store.runStoreIO storeHandle $+          runWorkflow name wid (rollingTotal counter 1 2)+      Right (Just row) <- Store.runStoreIO storeHandle $ Instance.lookupInstance name wid+      row ^. #generation `shouldBe` 1+      row ^. #status `shouldBe` Instance.WfRunning++    it "does not let a late append resurrect a terminal instance row" $ \storeHandle -> do+      counter <- newIORef (0 :: Int)+      let name = WorkflowName "inst-terminal"+          wid = WorkflowId "it-1"+      Right (Completed _) <- Store.runStoreIO storeHandle $ runWorkflow name wid (demoWorkflow counter)+      now <- getCurrentTime+      Right () <-+        Store.runStoreIO storeHandle $+          appendJournalEntry name wid (StepRecorded "late" (toJSON True) now)+      Right (Just row) <- Store.runStoreIO storeHandle $ Instance.lookupInstance name wid+      row ^. #status `shouldBe` Instance.WfCompleted++    it "discovers unfinished workflows from the instance table" $ \storeHandle -> do+      counter <- newIORef (0 :: Int)+      let completedName = WorkflowName "discover-completed"+          cancelledName = WorkflowName "discover-cancelled"+          crashedName = WorkflowName "discover-crashed"+          rotatedName = WorkflowName "discover-rotated"+      Right (Completed _) <-+        Store.runStoreIO storeHandle $+          runWorkflow completedName (WorkflowId "done") (demoWorkflow counter)+      cancelledAt <- getCurrentTime+      Right () <-+        Store.runStoreIO storeHandle $+          appendJournalEntry cancelledName (WorkflowId "cancelled") (WorkflowCancelled cancelledAt)+      Left (_ :: SimulatedCrash) <-+        try $+          Store.runStoreIO storeHandle $+            runWorkflow crashedName (WorkflowId "crashed") (crashAfterStep1 counter)+      Right ContinuedAsNew <-+        Store.runStoreIO storeHandle $+          runWorkflow rotatedName (WorkflowId "rotated") (rollingTotal counter 1 2)+      now <- getCurrentTime+      Right unfinished <- Store.runStoreIO storeHandle (findUnfinishedWorkflowIds now)+      unfinished+        `shouldBe` [ ("crashed", "discover-crashed"),+                     ("rotated", "discover-rotated")+                   ]++  describe "Keiro.Workflow snapshots" $ around (withFreshStore fixture) $ do+    it "does not fail committed workflow steps when snapshot writes fail" $ \storeHandle -> do+      (exporter, metricsRef) <- inMemoryMetricExporter+      (provider, _env) <-+        createMeterProvider+          emptyMaterializedResources+          defaultSdkMeterProviderOptions {metricExporter = Just exporter}+      meter <- getMeter provider Telemetry.keiroInstrumentationLibrary+      keiroMetrics <- Telemetry.newKeiroMetrics meter+      let opts =+            defaultWorkflowRunOptions+              & #snapshotPolicy+              .~ Every 2+              & #metrics+              ?~ keiroMetrics+      Right () <-+        Store.runStoreIO storeHandle $+          Store.runTransaction $+            Tx.sql "ALTER TABLE keiro.keiro_snapshots ADD CONSTRAINT keiro_snapshots_no_writes CHECK (false) NOT VALID"+      counter <- newIORef (0 :: Int)+      result <-+        Store.runStoreIO storeHandle $+          runWorkflowWith opts (WorkflowName "snap-write-failure") (WorkflowId "wf1") (countingSixSteps counter)+      result `shouldBe` Right (Completed [1, 2, 3, 4, 5, 6])+      Right journal <-+        Store.runStoreIO storeHandle $+          Store.readStreamForward (StreamName "wf:snap-write-failure-wf1") (StreamVersion 0) 100+      Vector.length journal `shouldBe` 7+      Right snapshotVersionDuringFailure <-+        Store.runStoreIO storeHandle $+          Store.runTransaction $+            Tx.statement "wf:snap-write-failure-wf1" snapshotVersionForStreamStmt+      snapshotVersionDuringFailure `shouldBe` Nothing+      _ <- forceFlushMeterProvider provider Nothing+      exported <- readIORef metricsRef+      lookup "keiro.snapshot.write.failures" (flattenScalarPoints exported) `shouldBe` Just (IntNumber 3)+      Right () <-+        Store.runStoreIO storeHandle $+          Store.runTransaction $+            Tx.sql "ALTER TABLE keiro.keiro_snapshots DROP CONSTRAINT keiro_snapshots_no_writes"+      recoveryCounter <- newIORef (0 :: Int)+      recovery <-+        Store.runStoreIO storeHandle $+          runWorkflowWith opts (WorkflowName "snap-write-recovery") (WorkflowId "wf2") (countingSixSteps recoveryCounter)+      recovery `shouldBe` Right (Completed [1, 2, 3, 4, 5, 6])+      Right snapshotVersionAfterRecovery <-+        Store.runStoreIO storeHandle $+          Store.runTransaction $+            Tx.statement "wf:snap-write-recovery-wf2" snapshotVersionForStreamStmt+      snapshotVersionAfterRecovery `shouldBe` Just (StreamVersion 6)++    -- Validation (a): a snapshot row appears at the expected version and+    -- decodes to the full accumulated step map.+    it "writes a snapshot of the accumulated step map after Every 2 fires" $ \storeHandle -> do+      counter <- newIORef (0 :: Int)+      let name = WorkflowName "snap"+          wid = WorkflowId "w1"+      result <-+        Store.runStoreIO storeHandle $+          runWorkflowWith+            (defaultWorkflowRunOptions & #snapshotPolicy .~ Every 2)+            name+            wid+            (countingSixSteps counter)+      result `shouldBe` Right (Completed [1, 2, 3, 4, 5, 6])+      -- Every 2 fired at versions 2, 4, 6; the upsert keeps the highest (6).+      Right snapVersion <-+        Store.runStoreIO storeHandle $+          Store.runTransaction $+            Tx.statement "wf:snap-w1" snapshotVersionForStreamStmt+      snapVersion `shouldBe` Just (StreamVersion 6)+      -- and the row decodes to the six-entry accumulated map.+      Right mSeed <- Store.runStoreIO storeHandle $ loadWorkflowSnapshot (StreamName "wf:snap-w1")+      case mSeed of+        Just (m, v) -> do+          v `shouldBe` StreamVersion 6+          Map.keys m `shouldBe` ["s1", "s2", "s3", "s4", "s5", "s6"]+        Nothing -> expectationFailure "expected a workflow snapshot row"++    -- The OnTerminal completion-site wiring: only the final WorkflowCompleted+    -- append (version 7) triggers the snapshot.+    it "writes a terminal snapshot under OnTerminal at the completion version" $ \storeHandle -> do+      counter <- newIORef (0 :: Int)+      let name = WorkflowName "term"+          wid = WorkflowId "tm1"+      result <-+        Store.runStoreIO storeHandle $+          runWorkflowWith+            (defaultWorkflowRunOptions & #snapshotPolicy .~ OnTerminal)+            name+            wid+            (countingSixSteps counter)+      result `shouldBe` Right (Completed [1, 2, 3, 4, 5, 6])+      Right snapVersion <-+        Store.runStoreIO storeHandle $+          Store.runTransaction $+            Tx.statement "wf:term-tm1" snapshotVersionForStreamStmt+      snapVersion `shouldBe` Just (StreamVersion 7)++    -- Validation (b): re-hydration reads only the tail after the snapshot+    -- version, and the journaled steps short-circuit (the counter stays put).+    it "reads only the tail after the snapshot version on re-hydration" $ \storeHandle -> do+      counter <- newIORef (0 :: Int)+      let name = WorkflowName "tail"+          wid = WorkflowId "t1"+          opts = defaultWorkflowRunOptions & #snapshotPolicy .~ Every 2+      first <- Store.runStoreIO storeHandle $ runWorkflowWith opts name wid (countingSixSteps counter)+      first `shouldBe` Right (Completed [1, 2, 3, 4, 5, 6])+      afterFirst <- readIORef counter+      afterFirst `shouldBe` 6+      -- A full version-0 replay would read every journal event...+      Right full <-+        Store.runStoreIO storeHandle $+          Store.readStreamForward (StreamName "wf:tail-t1") (StreamVersion 0) 100+      Vector.length full `shouldBe` 7 -- six StepRecorded + one WorkflowCompleted+      -- ...whereas the runtime seeds from the snapshot and reads only the tail.+      Right (Just (seedMap, StreamVersion sv)) <-+        Store.runStoreIO storeHandle $ loadWorkflowSnapshot (StreamName "wf:tail-t1")+      Map.size seedMap `shouldBe` 6+      Right tailEvents <-+        Store.runStoreIO storeHandle $+          Store.readStreamForward (StreamName "wf:tail-t1") (StreamVersion sv) 100+      Vector.length tailEvents `shouldSatisfy` (< Vector.length full)+      Vector.length tailEvents `shouldBe` 1 -- only the WorkflowCompleted at v7+      -- Re-hydration completes from the seed without re-running any step.+      second <- Store.runStoreIO storeHandle $ runWorkflowWith opts name wid (countingSixSteps counter)+      second `shouldBe` Right (Completed [1, 2, 3, 4, 5, 6])+      afterSecond <- readIORef counter+      afterSecond `shouldBe` 6++    -- Validation (c): a Never run and an Every 2 run produce identical results+    -- and identical journals, and the snapshot seed equals a full replay.+    it "produces identical results and journals under Never and Every 2" $ \storeHandle -> do+      counterN <- newIORef (0 :: Int)+      counterE <- newIORef (0 :: Int)+      neverRes <-+        Store.runStoreIO storeHandle $+          runWorkflowWith+            (defaultWorkflowRunOptions & #snapshotPolicy .~ Never)+            (WorkflowName "corr-never")+            (WorkflowId "c1")+            (countingSixSteps counterN)+      everyRes <-+        Store.runStoreIO storeHandle $+          runWorkflowWith+            (defaultWorkflowRunOptions & #snapshotPolicy .~ Every 2)+            (WorkflowName "corr-every")+            (WorkflowId "c1")+            (countingSixSteps counterE)+      neverRes `shouldBe` Right (Completed [1, 2, 3, 4, 5, 6])+      everyRes `shouldBe` Right (Completed [1, 2, 3, 4, 5, 6])+      Right neverEvents <-+        Store.runStoreIO storeHandle $+          Store.readStreamForward (StreamName "wf:corr-never-c1") (StreamVersion 0) 100+      Right everyEvents <-+        Store.runStoreIO storeHandle $+          Store.readStreamForward (StreamName "wf:corr-every-c1") (StreamVersion 0) 100+      let stepResults evs =+            [ (k, v)+            | Right (StepRecorded k v _) <- decodeRecorded workflowJournalCodec <$> Vector.toList evs+            ]+      stepResults neverEvents `shouldBe` stepResults everyEvents+      -- The snapshot seed equals the map a full version-0 replay would fold.+      Right (Just (seedMap, _)) <-+        Store.runStoreIO storeHandle $ loadWorkflowSnapshot (StreamName "wf:corr-every-c1")+      seedMap `shouldBe` Map.fromList (stepResults everyEvents)++    -- Validation (d): an advisory snapshot whose discriminant no longer matches+    -- is ignored and the workflow hydrates via full replay.+    it "hydrates via full replay when the snapshot discriminant mismatches" $ \storeHandle -> do+      counter <- newIORef (0 :: Int)+      let name = WorkflowName "dmiss"+          wid = WorkflowId "d1"+          opts = defaultWorkflowRunOptions & #snapshotPolicy .~ Every 2+      _ <- Store.runStoreIO storeHandle $ runWorkflowWith opts name wid (countingSixSteps counter)+      Right () <-+        Store.runStoreIO storeHandle $+          Store.runTransaction $+            Tx.statement ("wf:dmiss-d1", "stale-shape") corruptSnapshotShapeStmt+      Right mSeed <- Store.runStoreIO storeHandle $ loadWorkflowSnapshot (StreamName "wf:dmiss-d1")+      mSeed `shouldBe` Nothing+      resumed <- Store.runStoreIO storeHandle $ runWorkflowWith opts name wid (countingSixSteps counter)+      resumed `shouldBe` Right (Completed [1, 2, 3, 4, 5, 6])++    -- Validation (d), second arm: corrupt snapshot JSON is treated as a miss.+    it "hydrates via full replay when the snapshot JSON is corrupt" $ \storeHandle -> do+      (exporter, metricsRef) <- inMemoryMetricExporter+      (provider, _env) <-+        createMeterProvider+          emptyMaterializedResources+          defaultSdkMeterProviderOptions {metricExporter = Just exporter}+      meter <- getMeter provider Telemetry.keiroInstrumentationLibrary+      keiroMetrics <- Telemetry.newKeiroMetrics meter+      counter <- newIORef (0 :: Int)+      let name = WorkflowName "cjson"+          wid = WorkflowId "d2"+          opts =+            defaultWorkflowRunOptions+              & #snapshotPolicy+              .~ Every 2+              & #metrics+              ?~ keiroMetrics+      _ <- Store.runStoreIO storeHandle $ runWorkflowWith opts name wid (countingSixSteps counter)+      Right () <-+        Store.runStoreIO storeHandle $+          Store.runTransaction $+            Tx.statement ("wf:cjson-d2", Aeson.String "bad") corruptSnapshotStateStmt+      Right mSeed <- Store.runStoreIO storeHandle $ loadWorkflowSnapshot (StreamName "wf:cjson-d2")+      mSeed `shouldBe` Nothing+      resumed <- Store.runStoreIO storeHandle $ runWorkflowWith opts name wid (countingSixSteps counter)+      resumed `shouldBe` Right (Completed [1, 2, 3, 4, 5, 6])+      _ <- forceFlushMeterProvider provider Nothing+      exported <- readIORef metricsRef+      let scalars = flattenScalarPoints exported+      lookup "keiro.snapshot.decode.failures" scalars `shouldBe` Just (IntNumber 1)+      lookup "keiro.snapshot.read.misses" scalars `shouldBe` Just (IntNumber 2)++  describe "Keiro.Workflow 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,+            resumed = 1,+            completed = 1,+            stillSuspended = 0,+            unknownName = 0,+            failed = 0,+            transientErrors = 0,+            leaseSkipped = 0+          }+      -- Step 1 short-circuited; steps 2 and 3 ran exactly once.+      readIORef counter >>= \c -> c `shouldBe` 3+      -- The journal now holds s1, s2, s3, WorkflowCompleted.+      Right recorded <-+        Store.runStoreIO storeHandle $+          Store.readStreamForward (StreamName "wf:crash-demo-cd-1") (StreamVersion 0) 10+      traverse (decodeRecorded workflowJournalCodec) (Vector.toList recorded)+        `shouldSatisfy` \case+          Right [StepRecorded "s1" _ _, StepRecorded "s2" _ _, StepRecorded "s3" _ _, WorkflowCompleted _] -> True+          _ -> False+      -- A second pass discovers nothing — the workflow is finished.+      Right summary2 <-+        Store.runStoreIO storeHandle $ resumeWorkflowsOnce defaultWorkflowResumeOptions registry+      summary2 `shouldBe` emptyResumeSummary++    -- M3: a workflow suspended on an awaited step is driven to Completed once+    -- that step is journaled (here simulated; an EP-39/EP-40 wake source would+    -- journal the same StepRecorded end to end).+    it "resumes a suspended workflow once its awaited step is journaled" $ \storeHandle -> do+      counter <- newIORef (0 :: Int)+      let name = WorkflowName "await-demo"+          wid = WorkflowId "ad-1"+      suspended <-+        Store.runStoreIO storeHandle $ runWorkflow name wid (awaitingThenStep counter)+      suspended `shouldBe` Right Suspended+      -- Simulate the wake source resolving the await.+      Right () <- Store.runStoreIO storeHandle $ do+        now <- liftIO getCurrentTime+        appendJournalEntry name wid (StepRecorded "awk:approval" (toJSON ("ok" :: Text)) now)+      let registry = Map.singleton name (WorkflowDef (\_wid -> awaitingThenStep counter))+      Right summary <-+        Store.runStoreIO storeHandle $ resumeWorkflowsOnce defaultWorkflowResumeOptions registry+      summary+        `shouldBe` ResumeSummary+          { discovered = 1,+            resumed = 1,+            completed = 1,+            stillSuspended = 0,+            unknownName = 0,+            failed = 0,+            transientErrors = 0,+            leaseSkipped = 0+          }+      readIORef counter >>= \c -> c `shouldBe` 1+      Right recorded <-+        Store.runStoreIO storeHandle $+          Store.readStreamForward (StreamName "wf:await-demo-ad-1") (StreamVersion 0) 10+      traverse (decodeRecorded workflowJournalCodec) (Vector.toList recorded)+        `shouldSatisfy` \case+          Right [StepRecorded "awk:approval" _ _, StepRecorded "use" _ _, WorkflowCompleted _] -> True+          _ -> False++    -- M4: a discovered workflow whose name is absent from the registry is+    -- skipped and counted, never silently dropped or fatal.+    it "skips and counts a workflow whose name is absent from the registry" $ \storeHandle -> do+      counter <- newIORef (0 :: Int)+      let name = WorkflowName "orphan"+          wid = WorkflowId "or-1"+      crashed <-+        try+          ( Store.runStoreIO storeHandle $+              runWorkflow name wid (crashAfterStep1 counter)+          ) ::+          IO (Either SomeException (Either Store.StoreError (WorkflowOutcome (Int, Int, Int))))+      case crashed of+        Left _ -> pure ()+        Right other -> expectationFailure ("expected a simulated crash, got " <> show other)+      -- Empty registry: the orphan is surfaced via unknownName, not completed.+      Right summary <-+        Store.runStoreIO storeHandle $ resumeWorkflowsOnce defaultWorkflowResumeOptions Map.empty+      summary+        `shouldBe` ResumeSummary+          { discovered = 1,+            resumed = 0,+            completed = 0,+            stillSuspended = 0,+            unknownName = 1,+            failed = 0,+            transientErrors = 0,+            leaseSkipped = 0+          }+      -- The journal is unchanged: still one step, no completion.+      Right recorded <-+        Store.runStoreIO storeHandle $+          Store.readStreamForward (StreamName "wf:orphan-or-1") (StreamVersion 0) 10+      Vector.length recorded `shouldBe` 1++    it "isolates a poison workflow so a healthy workflow still completes" $ \storeHandle -> do+      healthyCounter <- newIORef (0 :: Int)+      let poisonName = WorkflowName "poison"+          poisonId = WorkflowId "poison-1"+          healthyName = WorkflowName "healthy"+          healthyId = WorkflowId "healthy-1"+          opts =+            defaultWorkflowResumeOptions+              & #maxAttempts+              .~ 1+              & #logEvent+              .~ const (pure ())+          registry =+            Map.fromList+              [ (poisonName, WorkflowDef (\_ -> liftIO (throwIO SimulatedCrash) *> pure (0 :: Int))),+                (healthyName, WorkflowDef (\_ -> threeStep healthyCounter))+              ]+      now <- getCurrentTime+      Right () <-+        Store.runStoreIO storeHandle $+          appendJournalEntry poisonName poisonId (StepRecorded "seed" (toJSON True) now)+      crashed <-+        try+          ( Store.runStoreIO storeHandle $+              runWorkflow healthyName healthyId (crashAfterStep1 healthyCounter)+          ) ::+          IO (Either SomeException (Either Store.StoreError (WorkflowOutcome (Int, Int, Int))))+      case crashed of+        Left _ -> pure ()+        Right other -> expectationFailure ("expected a simulated crash, got " <> show other)+      Right summary <- Store.runStoreIO storeHandle $ resumeWorkflowsOnce opts registry+      summary+        `shouldBe` emptyResumeSummary+          { discovered = 2,+            resumed = 2,+            completed = 1,+            failed = 1+          }+      readIORef healthyCounter >>= \c -> c `shouldBe` 3+      Right (Just poisonRow) <- Store.runStoreIO storeHandle $ Instance.lookupInstance poisonName poisonId+      poisonRow ^. #status `shouldBe` Instance.WfFailed++    it "marks a crashing workflow failed and short-circuits later direct runs" $ \storeHandle -> do+      let name = WorkflowName "terminal-poison"+          wid = WorkflowId "tp-1"+          opts =+            defaultWorkflowResumeOptions+              & #maxAttempts+              .~ 1+              & #logEvent+              .~ const (pure ())+          registry = Map.singleton name (WorkflowDef (\_ -> liftIO (throwIO SimulatedCrash) *> pure (0 :: Int)))+      now <- getCurrentTime+      Right () <-+        Store.runStoreIO storeHandle $+          appendJournalEntry name wid (StepRecorded "seed" (toJSON True) now)+      Right summary <- Store.runStoreIO storeHandle $ resumeWorkflowsOnce opts registry+      failed summary `shouldBe` 1+      Right (Just row) <- Store.runStoreIO storeHandle $ Instance.lookupInstance name wid+      row ^. #status `shouldBe` Instance.WfFailed+      row ^. #attempts `shouldBe` 1+      direct <- Store.runStoreIO storeHandle $ runWorkflow name wid (step (StepName "never") (pure (1 :: Int)))+      direct `shouldBe` Right Failed+      Right recordedFailed <-+        Store.runStoreIO storeHandle $+          Store.readStreamForward (StreamName "wf:terminal-poison-tp-1") (StreamVersion 0) 10+      traverse (decodeRecorded workflowJournalCodec) (Vector.toList recordedFailed)+        `shouldSatisfy` \case+          Right events -> any (\case WorkflowFailed {} -> True; _ -> False) events+          _ -> False++    it "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` True+      Right claimedB <- Store.runStoreIO storeHandle $ Instance.claimInstance "owner-b" 30 name wid+      claimedB `shouldBe` False+      Right () <- Store.runStoreIO storeHandle $ Instance.releaseInstance "owner-a" False name wid+      Right claimedBAfterRelease <- Store.runStoreIO storeHandle $ Instance.claimInstance "owner-b" 30 name wid+      claimedBAfterRelease `shouldBe` True++    it "lets an expired workflow lease be taken and resets attempts on progressed release" $ \storeHandle -> do+      let name = WorkflowName "lease-expire"+          wid = WorkflowId "le-1"+      Right claimedA <- Store.runStoreIO storeHandle $ Instance.claimInstance "owner-a" 30 name wid+      claimedA `shouldBe` True+      Right attempt <-+        Store.runStoreIO storeHandle $+          Store.runTransaction $+            Instance.recordCrashTx "le-1" "lease-expire" "boom"+      attempt `shouldBe` 1+      Right () <-+        Store.runStoreIO storeHandle $+          Store.runTransaction $+            Tx.sql "UPDATE keiro.keiro_workflows SET lease_expires_at = now() - interval '1 second', next_attempt_at = now() - interval '1 second' WHERE workflow_id = 'le-1' AND workflow_name = 'lease-expire'"+      Right claimedB <- Store.runStoreIO storeHandle $ Instance.claimInstance "owner-b" 30 name wid+      claimedB `shouldBe` True+      Right () <- Store.runStoreIO storeHandle $ Instance.releaseInstance "owner-b" True name wid+      Right (Just row) <- Store.runStoreIO storeHandle $ Instance.lookupInstance name wid+      row ^. #attempts `shouldBe` 0+      row ^. #lastError `shouldBe` Nothing+      row ^. #nextAttemptAt `shouldBe` Nothing+      row ^. #leasedBy `shouldBe` Nothing++    it "skips a resume candidate held by another live lease owner" $ \storeHandle -> do+      ran <- newIORef False+      let name = WorkflowName "lease-skip"+          wid = WorkflowId "ls-1"+          registry =+            Map.singleton name $+              WorkflowDef+                ( \_ -> do+                    liftIO (writeIORef ran True)+                    pure (0 :: Int)+                )+      now <- getCurrentTime+      Right () <-+        Store.runStoreIO storeHandle $+          appendJournalEntry name wid (StepRecorded "seed" (toJSON True) now)+      Right foreignClaim <- Store.runStoreIO storeHandle $ Instance.claimInstance "foreign-owner" 30 name wid+      foreignClaim `shouldBe` True+      Right summary <- Store.runStoreIO storeHandle $ resumeWorkflowsOnce defaultWorkflowResumeOptions registry+      summary+        `shouldBe` emptyResumeSummary+          { discovered = 1,+            leaseSkipped = 1+          }+      readIORef ran `shouldReturn` False++    -- M4: resume on an already-completed workflow is a genuine no-op.+    it "discovers nothing for an already-completed workflow and is stable" $ \storeHandle -> do+      counter <- newIORef (0 :: Int)+      let name = WorkflowName "done-demo"+          wid = WorkflowId "dd-1"+      done <- Store.runStoreIO storeHandle $ runWorkflow name wid (threeStep counter)+      done `shouldBe` Right (Completed (1, 2, 3))+      readIORef counter >>= \c -> c `shouldBe` 3+      let registry = Map.singleton name (WorkflowDef (\_wid -> threeStep counter))+      Right summary1 <-+        Store.runStoreIO storeHandle $ resumeWorkflowsOnce defaultWorkflowResumeOptions registry+      summary1 `shouldBe` emptyResumeSummary+      Right summary2 <-+        Store.runStoreIO storeHandle $ resumeWorkflowsOnce defaultWorkflowResumeOptions registry+      summary2 `shouldBe` emptyResumeSummary+      readIORef counter >>= \c -> c `shouldBe` 3++  describe "Keiro.Workflow 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+      Right claimedA <- Store.runStoreIO storeHandle $ Instance.claimInstance "owner-a" 0.2 name wid+      claimedA `shouldBe` True+      outcome <- Store.runStoreIO storeHandle $ runWorkflowWith runOpts name wid body+      outcome `shouldBe` Right (Completed False)+      readIORef attemptedClaim `shouldReturn` Just False+      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` True+      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+      Right () <-+        Store.runStoreIO store $+          Store.runTransaction $+            Tx.sql "ALTER TABLE keiro.keiro_workflow_steps RENAME TO keiro_workflow_steps_hidden"+      worker <- forkIO (runWorkflowResumeWorkerPush store opts registry)+      logged <- waitForPassFailure+      logged `shouldBe` Just ()+      Right () <-+        Store.runStoreIO store $+          Store.runTransaction $+            Tx.sql "ALTER TABLE keiro.keiro_workflow_steps_hidden RENAME TO keiro_workflow_steps"+      now <- getCurrentTime+      Right () <-+        Store.runStoreIO store $+          appendJournalEntry name wid (StepRecorded "awk:gate" (toJSON ()) now)+      resumed <- timeout 5_000_000 (takeMVar done)+      status <- threadStatus worker+      killThread worker+      resumed `shouldBe` Just ()+      status `shouldSatisfy` \case+        ThreadFinished -> False+        ThreadDied -> False+        _ -> True++  describe "Keiro.Workflow push fallback (EP-50)" $ around (withFreshStore fixture) $ do+    -- Push is strictly an optimization: with the worker on 'neverWake' (every+    -- NOTIFY dropped) and a small fallback, the gated workflow still drains on+    -- the durable poll.+    it "still drains on the fallback timeout when no notification is delivered" $ \store -> do+      done <- newEmptyMVar+      let name = WorkflowName "fallbackwf"+          wid = WorkflowId "f-1"+          registry = Map.singleton name (WorkflowDef (\_ -> gateThenSignal done))+          onePass = void (Store.runStoreIO store (resumeWorkflowsOnce defaultWorkflowResumeOptions registry))+      first <- Store.runStoreIO store (runWorkflow name wid (gateThenSignal done))+      first `shouldBe` Right Suspended+      worker <- forkIO (runPollLoopWith neverWake 200000 onePass) -- 200 ms fallback, no notifications+      now <- getCurrentTime+      Right () <-+        Store.runStoreIO store $+          appendJournalEntry name wid (StepRecorded "awk:gate" (toJSON ()) now)+      resumed <- timeout 5000000 (takeMVar done)+      killThread worker+      resumed `shouldBe` Just ()++  describe "Shard lease" $ around (withFreshStore fixture) $ do+    -- EP-51 M2: claim / renew / release / expiry at the SQL layer, with explicit+    -- `now` timestamps standing in for the passage of time (no workers yet). The+    -- exclusion guarantee is the FOR UPDATE SKIP LOCKED claim; disjointness and+    -- failover are both observable purely from the lease table.+    let subName = SubscriptionName "orders-shard"+        wA = WorkerId sampleUuid+        wB = WorkerId sampleUuid2+        ttl = 30 :: NominalDiffTime+        t0 = UTCTime (ModifiedJulianDay 60000) (secondsToDiffTime 0)+        tExpired = addUTCTime 60 t0 -- past A's 30 s lease+        shardOpts = defaultShardedWorkerOptions (Category (CategoryName "orders")) 4+    it "validates sharded worker options before startup" $ \_store -> do+      shouldBeRight_ (mkShardedWorkerOptions shardOpts)+      mkShardedWorkerOptions (shardOpts & #shardCount .~ 0)+        `shouldBeLeft` InvalidShardCount 0+      mkShardedWorkerOptions (shardOpts & #leaseTtl .~ 0)+        `shouldBeLeft` InvalidShardLeaseTtl 0+      mkShardedWorkerOptions (shardOpts & #renewInterval .~ 0)+        `shouldBeLeft` InvalidShardRenewInterval 0+      mkShardedWorkerOptions (shardOpts & #leaseTtl .~ 10 & #renewInterval .~ 10)+        `shouldBeLeft` InvalidShardLeaseRenewInterval 10 10+      mkShardedWorkerOptions (shardOpts & #batchSize .~ 0)+        `shouldBeLeft` InvalidShardBatchSize 0+      mkShardedWorkerOptions (shardOpts & #bufferSize .~ 0)+        `shouldBeLeft` InvalidShardBufferSize 0+      mkShardedWorkerOptions (shardOpts & #handlerRetryDelay .~ KirokuSub.RetryDelay (-1))+        `shouldBeLeft` InvalidShardHandlerRetryDelay (KirokuSub.RetryDelay (-1))+      mkShardedWorkerOptions (shardOpts & #retryPolicy .~ KirokuSub.RetryPolicy 0)+        `shouldBeLeft` InvalidShardRetryMaxAttempts 0++    it "ensureShardRows populates N rows once (idempotent on re-run)" $ \store -> do+      Right () <- Store.runStoreIO store $ Store.runTransaction $ do+        ensureShardRows subName 4+        ensureShardRows subName 4+      Right rows <- Store.runStoreIO store $ Store.runTransaction (listShardOwnership subName)+      map (\(b, _, _) -> b) rows `shouldBe` [0, 1, 2, 3]+      all (\(_, o, _) -> isNothing o) rows `shouldBe` True++    it "worker A claims all N when free; B claims 0 while A holds valid leases" $ \store -> do+      Right claimedA <- Store.runStoreIO store $ Store.runTransaction $ do+        ensureShardRows subName 4+        claimShardsTx subName wA 4 t0 ttl+      claimedA `shouldBe` [0, 1, 2, 3]+      Right claimedB <- Store.runStoreIO store $ Store.runTransaction (claimShardsTx subName wB 4 t0 ttl)+      claimedB `shouldBe` []++    it "B claims A's buckets after A's lease expires; A then renews nothing" $ \store -> do+      Right _ <- Store.runStoreIO store $ Store.runTransaction $ do+        ensureShardRows subName 4+        claimShardsTx subName wA 4 t0 ttl+      Right claimedB <- Store.runStoreIO store $ Store.runTransaction (claimShardsTx subName wB 4 tExpired ttl)+      claimedB `shouldBe` [0, 1, 2, 3]+      -- A lost every bucket to B, so its renew returns the empty set: this is how+      -- a worker learns it no longer owns a bucket and stops reading it.+      Right heldA <- Store.runStoreIO store $ Store.runTransaction (renewLeaseTx subName wA tExpired ttl)+      heldA `shouldBe` []++    it "renewLease returns only still-held buckets" $ \store -> do+      Right held <- Store.runStoreIO store $ Store.runTransaction $ do+        ensureShardRows subName 4+        _ <- claimShardsTx subName wA 4 t0 ttl+        renewLeaseTx subName wA t0 ttl+      held `shouldBe` [0, 1, 2, 3]++    it "releaseShards: relinquished buckets are immediately claimable" $ \store -> do+      Right _ <- Store.runStoreIO store $ Store.runTransaction $ do+        ensureShardRows subName 4+        _ <- claimShardsTx subName wA 4 t0 ttl+        releaseShardsTx subName wA [0, 1]+      -- Even while A's lease over 2,3 is still valid, the released 0,1 are claimable.+      Right claimedB <- Store.runStoreIO store $ Store.runTransaction (claimShardsTx subName wB 4 t0 ttl)+      claimedB `shouldBe` [0, 1]++    it "fairShareTarget divides buckets evenly (ceil)" $ \_store -> do+      fairShareTarget 6 3 `shouldBe` 2+      fairShareTarget 6 4 `shouldBe` 2+      fairShareTarget 7 3 `shouldBe` 3+      fairShareTarget 4 0 `shouldBe` 4 -- a non-positive estimate claims everything+    it "acquireOutcome keeps previous ownership on acquire failure" $ \_store -> do+      let previous = Set.fromList [0, 2]+      acquireOutcome previous (Left "database unavailable")+        `shouldBe` (previous, Just (ShardAcquireFailed "database unavailable"))+      acquireOutcome previous (Right (Set.fromList [1, 3]))+        `shouldBe` (Set.fromList [1, 3], Nothing)++    it "ensureShards rejects a shardCount mismatch" $ \store -> do+      let lease4 =+            ShardLease+              { subscriptionName = subName,+                workerId = wA,+                shardCount = 4,+                leaseTtl = ttl+              }+          lease6 =+            ShardLease+              { subscriptionName = subName,+                workerId = wA,+                shardCount = 6,+                leaseTtl = ttl+              }+      Right () <- Store.runStoreIO store (ensureShards lease4)+      Store.runStoreIO store (ensureShards lease6)+        `shouldThrow` \case+          ShardCountMismatch name configured found ->+            name == "orders-shard" && configured == 6 && found == [4]++  describe "Sharded subscription single worker" $ around (withFreshStore fixture) $ do+    -- EP-51 M3: one process owning all N buckets drains a seeded category exactly+    -- once. The sink is idempotent on event_id, so "count == total" proves every+    -- event was delivered with none missing and none surviving as a duplicate row.+    it "one worker with N=4 buckets drains a seeded category exactly once" $ \store -> do+      Right () <- Store.runStoreIO store $ Store.runTransaction (Tx.sql createShardSinkSql)+      total <- seedOrders store 8 5 -- 40 events across 8 streams+      let opts =+            (defaultShardedWorkerOptions (Category (CategoryName "orders")) 4)+              { leaseTtl = 3,+                renewInterval = 0.3+              }+      w <- forkIO (runShardedSubscriptionGroup store (SubscriptionName "orders-sub") opts (sinkHandler store 1))+      drained <- waitUntilSinkCount store total 20_000_000+      killThread w+      drained `shouldBe` True+      count <- shardSinkCount store+      count `shouldBe` total+      maxW <- maxWorkersPerStream store+      maxW `shouldBe` 1++  describe "Sharded subscription drain and failover" $ around (withFreshStore fixture) $ do+    -- EP-51 M5: the behavioural acceptance. Three worker processes cooperatively+    -- partition a category; we let ownership converge on the *empty* category+    -- first (so the churn of cold-start rebalancing touches no events), then seed+    -- and drain under stable membership — so each stream is owned by exactly one+    -- worker throughout the drain. Then we kill a worker and prove its buckets are+    -- re-homed and the new events drain (failover via lease expiry).+    let sub = SubscriptionName "orders-failover"+        mkOpts = (defaultShardedWorkerOptions (Category (CategoryName "orders")) 6) {leaseTtl = 3, renewInterval = 0.3}+    it "three workers drain disjointly, then re-home a killed worker's buckets" $ \store -> do+      Right () <- Store.runStoreIO store $ Store.runTransaction (Tx.sql createShardSinkSql)+      w1 <- forkIO (runShardedSubscriptionGroup store sub mkOpts (sinkHandler store 1))+      w2 <- forkIO (runShardedSubscriptionGroup store sub mkOpts (sinkHandler store 2))+      w3 <- forkIO (runShardedSubscriptionGroup store sub mkOpts (sinkHandler store 3))+      -- Wait for cooperative balance on the empty category: all 6 buckets owned,+      -- spread across >= 2 workers, none holding more than its fair share.+      balanced <- waitShardsBalanced store sub 6 2 15_000_000+      balanced `shouldBe` True+      -- Now seed and drain under stable membership.+      total1 <- seedOrders store 12 5 -- 60 events+      ok1 <- waitUntilSinkCount store total1 25_000_000+      ok1 `shouldBe` True+      -- Disjoint: no stream key was processed by two workers (stable membership,+      -- so no re-homing split any stream).+      maxW <- maxWorkersPerStream store+      maxW `shouldBe` 1+      -- The work genuinely spread (not a monopoly): at least two workers participated.+      spread <- distinctWorkers store+      spread `shouldSatisfy` (>= 2)+      -- Counts sum to total with no duplicate event id (PK on event_id + count).+      c1 <- shardSinkCount store+      c1 `shouldBe` total1+      -- Kill worker 1 (its readers stop; it stops renewing, so its leases expire).+      killThread w1+      -- Seed more across all streams; some hash to worker 1's now-orphaned buckets.+      total2 <- seedOrders store 12 5 -- another 60+      -- Failover: a surviving worker re-claims the expired buckets and drains the+      -- new events. If re-homing did not happen, events on worker 1's buckets would+      -- never drain and this would time out.+      ok2 <- waitUntilSinkCount store (total1 + total2) 30_000_000+      killThread w2+      killThread w3+      ok2 `shouldBe` True+      c2 <- shardSinkCount store+      c2 `shouldBe` (total1 + total2)++    it "a killed worker relinquishes its leases immediately" $ \store -> do+      let subImmediate = SubscriptionName "orders-immediate-release"+          longTtlOpts =+            (defaultShardedWorkerOptions (Category (CategoryName "orders")) 4)+              { leaseTtl = 30,+                renewInterval = 0.2+              }+      w <- forkIO (runShardedSubscriptionGroup store subImmediate longTtlOpts (sinkHandler store 1))+      owned <- waitShardsBalanced store subImmediate 4 1 10_000_000+      owned `shouldBe` True+      killThread w+      released <- waitShardsUnowned store subImmediate 4 3_000_000+      released `shouldBe` True++    it "a handler exception is retried in place and drains" $ \store -> do+      Right () <- Store.runStoreIO store $ Store.runTransaction (Tx.sql createShardSinkSql)+      thrown <- newIORef False+      errors <- newIORef []+      let subRestart = SubscriptionName "orders-reader-restart"+          opts =+            (defaultShardedWorkerOptions (Category (CategoryName "orders")) 2)+              { leaseTtl = 3,+                renewInterval = 0.2,+                handlerRetryDelay = KirokuSub.RetryDelay 0.05,+                onShardError = Just (\err -> modifyIORef' errors (err :))+              }+          handler ev = do+            firstTime <-+              atomicModifyIORef'+                thrown+                ( \seen ->+                    if seen+                      then (seen, False)+                      else (True, True)+                )+            when firstTime (throwIO (userError "reader boom"))+            sinkHandler store 1 ev+      w <- forkIO (runShardedSubscriptionGroup store subRestart opts handler)+      balanced <- waitShardsBalanced store subRestart 2 1 10_000_000+      balanced `shouldBe` True+      total <- seedOrders store 4 2+      drained <- waitUntilSinkCount store total 20_000_000+      killThread w+      drained `shouldBe` True+      seenErrors <- readIORef errors+      seenErrors `shouldSatisfy` all (\case ShardReaderDied _ _ -> False; _ -> True)++  describe "Sharded subscription ack coupling" $ around (withFreshStore fixture) $ do+    it "redelivers a batch-tail event whose handler was killed mid-flight" $ \store -> do+      Right () <- Store.runStoreIO store $ Store.runTransaction (Tx.sql createShardSinkSql)+      total <- seedOrders store 1 5+      enteredTail <- newEmptyMVar+      holdTail <- newEmptyMVar+      let sub = SubscriptionName "orders-ack-tail"+          opts =+            (defaultShardedWorkerOptions (Category (CategoryName "orders")) 1)+              { leaseTtl = 3,+                renewInterval = 0.3+              }+          blockingHandler ev = do+            let orderNumber = parseEither (withObject "OrderPlaced" (.: "n")) (ev ^. #payload)+            when (orderNumber == Right (4 :: Int)) $ do+              putMVar enteredTail ()+              takeMVar holdTail+            sinkHandler store 1 ev+      first <- forkIO (runShardedSubscriptionGroup store sub opts blockingHandler)+      entered <- timeout 10_000_000 (takeMVar enteredTail)+      entered `shouldBe` Just ()+      -- The old pull bridge replies Continue before invoking the handler;+      -- leave enough time for its batch-tail checkpoint to commit while the+      -- handler remains blocked. The ack-coupled bridge introduced by EP-96+      -- remains blocked on the unfilled reply instead.+      threadDelay 200_000+      killThread first+      second <- forkIO (runShardedSubscriptionGroup store sub opts (sinkHandler store 2))+      drained <- waitUntilSinkCount store total 20_000_000+      killThread second+      drained `shouldBe` True+      shardSinkCount store `shouldReturn` total++    it "loses no events when a bucket is shed mid-drain during rebalance" $ \store -> do+      Right () <- Store.runStoreIO store $ Store.runTransaction (Tx.sql createShardSinkSql)+      total <- seedOrders store 24 5+      let sub = SubscriptionName "orders-ack-rebalance"+          opts =+            (defaultShardedWorkerOptions (Category (CategoryName "orders")) 4)+              { leaseTtl = 3,+                renewInterval = 0.3,+                batchSize = 1+              }+          slowHandler tag ev = do+            threadDelay 100_000+            sinkHandler store tag ev+      first <- forkIO (runShardedSubscriptionGroup store sub opts (slowHandler 1))+      -- acquireOwnedBuckets claims one bucket per pass. Starting the joiner+      -- while A owns three leaves one claimable bucket for B, making B visible;+      -- A's next pass then sheds its excess third bucket while its handler is+      -- deliberately slow and in flight.+      ownsThree <- waitUntilOwnedShardCount store sub 3 10_000_000+      ownsThree `shouldBe` True+      second <- forkIO (runShardedSubscriptionGroup store sub opts (slowHandler 2))+      drained <- waitUntilSinkCount store total 30_000_000+      killThread first+      killThread second+      drained `shouldBe` True+      shardSinkCount store `shouldReturn` total++    it "allows zombie overlap duplicates without losing an event" $ \store -> do+      Right () <- Store.runStoreIO store $ Store.runTransaction (Tx.sql createShardSinkSql)+      total <- seedOrders store 1 5+      entered <- newEmptyMVar+      release <- newEmptyMVar+      deliveries <- newIORef ([] :: [EventId])+      successor <- newIORef Nothing+      readersA <- newIORef Map.empty+      let sub = SubscriptionName "orders-ack-zombie"+          opts =+            (defaultShardedWorkerOptions (Category (CategoryName "orders")) 1)+              { leaseTtl = 2,+                renewInterval = 0.2+              }+          leaseA =+            ShardLease+              { subscriptionName = sub,+                workerId = WorkerId sampleUuid,+                shardCount = 1,+                leaseTtl = 2+              }+          handlerA delivery = do+            let ev = delivery ^. #event+            modifyIORef' deliveries ((ev ^. #eventId) :)+            putMVar entered ()+            takeMVar release+            sinkHandler store 1 ev+            pure ShardAckOk+          handlerB delivery = do+            let ev = delivery ^. #event+            modifyIORef' deliveries ((ev ^. #eventId) :)+            sinkHandler store 2 ev+            pure ShardAckOk+          cleanup = do+            void (tryPutMVar release ())+            mSuccessor <- readIORef successor+            for_ mSuccessor killThread+            now <- getCurrentTime+            let cleanupWorker = WorkerId sampleUuid2+            _ <- Store.runStoreIO store $ Store.runTransaction $ do+              releaseShardsTx sub (WorkerId sampleUuid) [0]+              claimShardsTx sub cleanupWorker 1 now 30+            void (reconcileShardsOnce store leaseA opts readersA handlerA)+      ( do+          Right () <- Store.runStoreIO store (ensureShards leaseA)+          void (reconcileShardsOnce store leaseA opts readersA handlerA)+          timeout 10_000_000 (takeMVar entered) `shouldReturn` Just ()+          -- A no longer renews, but its reader remains alive and blocked+          -- with one unacknowledged event. B can claim after expiry and+          -- must therefore receive that event again from the checkpoint.+          threadDelay 2_500_000+          workerB <- forkIO (runShardedSubscriptionGroupAck store sub opts handlerB)+          writeIORef successor (Just workerB)+          drained <- waitUntilSinkCount store total 20_000_000+          drained `shouldBe` True+          raw <- readIORef deliveries+          length raw `shouldSatisfy` (> total)+          shardSinkCount store `shouldReturn` total+        )+        `finally` cleanup++    it "dead-letters a poison event after bounded retries and keeps draining" $ \store -> do+      Right () <- Store.runStoreIO store $ Store.runTransaction (Tx.sql createShardSinkSql)+      total <- seedOrders store 1 4+      poisonDeliveries <- newIORef (0 :: Int)+      errors <- newIORef []+      let sub = SubscriptionName "orders-ack-poison"+          opts =+            (defaultShardedWorkerOptions (Category (CategoryName "orders")) 1)+              { leaseTtl = 3,+                renewInterval = 0.2,+                handlerRetryDelay = KirokuSub.RetryDelay 0.05,+                retryPolicy = KirokuSub.RetryPolicy 3,+                onShardError = Just (\err -> modifyIORef' errors (err :))+              }+          handler ev = do+            let orderNumber = parseEither (withObject "OrderPlaced" (.: "n")) (ev ^. #payload)+            if orderNumber == Right (1 :: Int)+              then do+                modifyIORef' poisonDeliveries (+ 1)+                throwIO (userError "poison order")+              else sinkHandler store 1 ev+      worker <- forkIO (runShardedSubscriptionGroup store sub opts handler)+      drained <- waitUntilSinkCount store (total - 1) 20_000_000+      details <- shardDeadLetterDetails store "orders-ack-poison"+      attempts <- readIORef poisonDeliveries+      seenErrors <- readIORef errors+      killThread worker+      drained `shouldBe` True+      attempts `shouldBe` 3+      details `shouldBe` (1, Just "max retry attempts exceeded (3)", Just 3)+      seenErrors `shouldSatisfy` all (\case ShardReaderDied _ _ -> False; _ -> True)++  describe "Keiro.Workflow observability" $ around (withFreshStore fixture) $ do+    -- The headline operability signal: executed (real work) vs replayed+    -- (recorded history), recorded by the runtime through an SDK meter and read+    -- back from the in-memory exporter — plus the active gauge and the+    -- journal-length histogram.+    it "records workflow instruments through an SDK meter" $ \storeHandle -> do+      (exporter, ref) <- inMemoryMetricExporter+      (provider, _env) <-+        createMeterProvider+          emptyMaterializedResources+          defaultSdkMeterProviderOptions {metricExporter = Just exporter}+      meter <- getMeter provider Telemetry.keiroInstrumentationLibrary+      metrics <- Telemetry.newKeiroMetrics meter+      counter <- newIORef (0 :: Int)+      let name = WorkflowName "obs"+          wid = WorkflowId "obs-1"+          opts = defaultWorkflowRunOptions & #metrics .~ Just metrics+      -- First run: both steps miss → two executions.+      first <- Store.runStoreIO storeHandle $ runWorkflowWith opts name wid (demoWorkflow counter)+      first `shouldBe` Right (Completed (1, 2))+      -- Second run, same id: both steps hit → two replays.+      second <- Store.runStoreIO storeHandle $ runWorkflowWith opts name wid (demoWorkflow counter)+      second `shouldBe` Right (Completed (1, 2))+      -- The side effects ran exactly twice across both runs (the replay run+      -- short-circuited every step).+      readIORef counter >>= \c -> c `shouldBe` 2+      _ <- forceFlushMeterProvider provider Nothing+      exported <- readIORef ref+      let scalars = flattenScalarPoints exported+          hists = flattenHistogramPoints exported+      lookup "keiro.workflow.steps.executed" scalars `shouldBe` Just (IntNumber 2)+      lookup "keiro.workflow.steps.replayed" scalars `shouldBe` Just (IntNumber 2)+      -- One journal-length observation per completed run (two completions).+      [c | (n, c, _) <- hists, n == "keiro.workflow.journal.length"] `shouldBe` [2]+      -- Both runs finished, so the live-run count returned to zero.+      lookup "keiro.workflow.active" scalars `shouldBe` Just (IntNumber 0)++    -- The resume worker increments keiro.workflow.resumed per re-invocation and+    -- samples keiro.workflow.awakeables.pending each pass.+    it "records a resume and the pending-awakeable count when the worker re-invokes" $ \storeHandle -> do+      (exporter, ref) <- inMemoryMetricExporter+      (provider, _env) <-+        createMeterProvider+          emptyMaterializedResources+          defaultSdkMeterProviderOptions {metricExporter = Just exporter}+      meter <- getMeter provider Telemetry.keiroInstrumentationLibrary+      metrics <- Telemetry.newKeiroMetrics meter+      counter <- newIORef (0 :: Int)+      let name = WorkflowName "obs-resume"+          wid = WorkflowId "obs-r-1"+      -- Suspend a workflow so it has a step row but no completion: the resume+      -- worker will re-invoke it (and stay Suspended, which still counts as a+      -- re-invocation).+      suspended <- Store.runStoreIO storeHandle $ runWorkflow name wid (stepThenAwaitWorkflow counter)+      suspended `shouldBe` Right Suspended+      -- Register one pending awakeable (independent of the suspended workflow's+      -- own await) so the pending gauge has something to count.+      let aid = awakeableIdToUuid (deterministicAwakeableId (WorkflowName "ext") (WorkflowId "1") "cb")+      Right () <-+        Store.runStoreIO storeHandle $ Store.runTransaction $ Awk.registerAwakeableTx aid "ext" "1"+      -- One resume pass with metrics threaded through the run options.+      let registry = Map.singleton name (WorkflowDef (\_wid -> stepThenAwaitWorkflow counter))+          resumeOpts =+            defaultWorkflowResumeOptions+              & #runOptions+              .~ (defaultWorkflowRunOptions & #metrics .~ Just metrics)+      Right _summary <- Store.runStoreIO storeHandle $ resumeWorkflowsOnce resumeOpts registry+      _ <- forceFlushMeterProvider provider Nothing+      exported <- readIORef ref+      let scalars = flattenScalarPoints exported+      lookup "keiro.workflow.resumed" scalars `shouldBe` Just (IntNumber 1)+      lookup "keiro.workflow.awakeables.pending" scalars `shouldBe` Just (IntNumber 1)++    -- The no-op idiom end to end: defaultWorkflowRunOptions carries metrics =+    -- Nothing, so a run on a dedicated provider exports no points at all.+    it "records nothing through a Nothing handle" $ \storeHandle -> do+      (exporter, ref) <- inMemoryMetricExporter+      (provider, _env) <-+        createMeterProvider+          emptyMaterializedResources+          defaultSdkMeterProviderOptions {metricExporter = Just exporter}+      counter <- newIORef (0 :: Int)+      result <-+        Store.runStoreIO storeHandle $+          runWorkflow (WorkflowName "obs-noop") (WorkflowId "obs-n-1") (demoWorkflow counter)+      result `shouldBe` Right (Completed (1, 2))+      _ <- forceFlushMeterProvider provider Nothing+      exported <- readIORef ref+      flattenScalarPoints exported `shouldBe` []+      flattenHistogramPoints exported `shouldBe` []++  describe "Keiro.Workflow.Snapshot codec" $ do+    -- Pure (no-DB) round-trip of the workflow state codec.+    it "round-trips a non-trivial accumulated step map and carries the sentinel shape hash" $ do+      let m =+            Map.fromList+              [ ("first", toJSON (1 :: Int)),+                ("second", toJSON ["a", "b" :: Text]),+                ("sleep:42", Aeson.Null)+              ]+      (workflowStateCodec ^. #decode) ((workflowStateCodec ^. #encode) m) `shouldBe` Right m+      (workflowStateCodec ^. #shapeHash) `shouldBe` "keiro.workflow.stepmap.v1"+      (workflowStateCodec ^. #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.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.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.Awakeable" $ do+    -- Pure (no-DB) check of the deterministic id derivation.+    it "derives a deterministic AwakeableId, stable across calls and label-sensitive" $ do+      let aid1 = deterministicAwakeableId (WorkflowName "w") (WorkflowId "1") "approval"+          aid2 = deterministicAwakeableId (WorkflowName "w") (WorkflowId "1") "approval"+          aidOther = deterministicAwakeableId (WorkflowName "w") (WorkflowId "1") "other"+          awakeableGolden = uuidLiteral "ccaeaf74-3ffe-5ea5-a118-a3441a95c279"+      aid1 `shouldBe` aid2+      (aid1 == aidOther) `shouldBe` False+      aid1 `shouldBe` AwakeableId awakeableGolden++    around (withFreshStore fixture) $ do+      it "schema: registers, completes once (idempotent), cancels, and counts pending rows" $ \storeHandle -> do+        let aidA = awakeableIdToUuid (deterministicAwakeableId (WorkflowName "sch") (WorkflowId "1") "a")+            aidB = awakeableIdToUuid (deterministicAwakeableId (WorkflowName "sch") (WorkflowId "1") "b")+        now <- getCurrentTime+        Right () <- Store.runStoreIO storeHandle $ Store.runTransaction $ do+          Awk.registerAwakeableTx aidA "sch" "1"+          Awk.registerAwakeableTx aidB "sch" "1"+        Right pendingCount <- Store.runStoreIO storeHandle Awk.countPendingAwakeables+        pendingCount `shouldBe` 2+        Right (Just rowA) <- Store.runStoreIO storeHandle $ Awk.lookupAwakeable aidA+        rowA ^. #status `shouldBe` Awk.Pending+        rowA ^. #payload `shouldBe` Nothing+        -- Complete A once; the status-guarded UPDATE makes a re-complete a no-op.+        Right firstComplete <-+          Store.runStoreIO storeHandle $+            Store.runTransaction $+              Awk.completeAwakeableTx aidA (toJSON ("done" :: Text)) now+        firstComplete `shouldBe` True+        Right secondComplete <-+          Store.runStoreIO storeHandle $+            Store.runTransaction $+              Awk.completeAwakeableTx aidA (toJSON ("again" :: Text)) now+        secondComplete `shouldBe` False+        Right (Just rowA') <- Store.runStoreIO storeHandle $ Awk.lookupAwakeable aidA+        rowA' ^. #status `shouldBe` Awk.Completed+        rowA' ^. #payload `shouldBe` Just (toJSON ("done" :: Text))+        -- Cancel the still-pending B; both rows are now resolved.+        Right cancelled <-+          Store.runStoreIO storeHandle $+            Store.runTransaction $+              Awk.cancelAwakeableTx aidB+        cancelled `shouldBe` True+        Right pendingAfter <- Store.runStoreIO storeHandle Awk.countPendingAwakeables+        pendingAfter `shouldBe` 0++      it "suspends on an unsignalled awakeable, recording a pending row and no completion" $ \storeHandle -> do+        aidRef <- newIORef Nothing+        let name = WorkflowName "approval"+            wid = WorkflowId "wf1"+        outcome1 <- Store.runStoreIO storeHandle $ runWorkflow name wid (approvalFlowWithId aidRef)+        outcome1 `shouldBe` Right Suspended+        aid <- readRequiredAwakeableId aidRef+        Right (Just row) <- Store.runStoreIO storeHandle $ Awk.lookupAwakeable (awakeableIdToUuid aid)+        row ^. #status `shouldBe` Awk.Pending+        row ^. #payload `shouldBe` Nothing+        Right pendingNow <- Store.runStoreIO storeHandle Awk.countPendingAwakeables+        pendingNow `shouldBe` 1+        Right recorded <-+          Store.runStoreIO storeHandle $+            Store.readStreamForward (StreamName "wf:approval-wf1") (StreamVersion 0) 100+        traverse (decodeRecorded workflowJournalCodec) (Vector.toList recorded)+          `shouldSatisfy` \case+            Right [StepRecorded stepName value _] ->+              stepName == awakeableAllocStepPrefix <> "approval" && value == toJSON aid+            _ -> False++      it "resumes with the signalled payload after signalAwakeable" $ \storeHandle -> do+        aidRef <- newIORef Nothing+        let name = WorkflowName "approval"+            wid = WorkflowId "wf1"+        Right Suspended <- Store.runStoreIO storeHandle $ runWorkflow name wid (approvalFlowWithId aidRef)+        aid <- readRequiredAwakeableId aidRef+        let awkStep = "awk:" <> awakeableIdText aid+        Right signalled <- Store.runStoreIO storeHandle $ signalAwakeable aid ("ok" :: Text)+        signalled `shouldBe` True+        Right (Just row) <- Store.runStoreIO storeHandle $ Awk.lookupAwakeable (awakeableIdToUuid aid)+        row ^. #status `shouldBe` Awk.Completed+        row ^. #payload `shouldBe` Just (toJSON ("ok" :: Text))+        Right afterSignal <-+          Store.runStoreIO storeHandle $+            Store.readStreamForward (StreamName "wf:approval-wf1") (StreamVersion 0) 100+        traverse (decodeRecorded workflowJournalCodec) (Vector.toList afterSignal)+          `shouldSatisfy` \case+            Right [StepRecorded allocStep _ _, StepRecorded s r _] ->+              allocStep == awakeableAllocStepPrefix <> "approval" && s == awkStep && r == toJSON ("ok" :: Text)+            _ -> False+        outcome2 <- Store.runStoreIO storeHandle $ runWorkflow name wid (approvalFlowWithId aidRef)+        outcome2 `shouldBe` Right (Completed "ok!")+        Right afterResume <-+          Store.runStoreIO storeHandle $+            Store.readStreamForward (StreamName "wf:approval-wf1") (StreamVersion 0) 100+        traverse (decodeRecorded workflowJournalCodec) (Vector.toList afterResume)+          `shouldSatisfy` \case+            Right [StepRecorded allocStep _ _, StepRecorded s1 _ _, StepRecorded "use" _ _, WorkflowCompleted _] ->+              allocStep == awakeableAllocStepPrefix <> "approval" && s1 == awkStep+            _ -> False++      it "is idempotent: a second signal returns False and does not change the value" $ \storeHandle -> do+        aidRef <- newIORef Nothing+        let name = WorkflowName "idem"+            wid = WorkflowId "wf-i"+        Right Suspended <- Store.runStoreIO storeHandle $ runWorkflow name wid (approvalFlowWithId aidRef)+        aid <- readRequiredAwakeableId aidRef+        let awkStep = "awk:" <> awakeableIdText aid+        Right True <- Store.runStoreIO storeHandle $ signalAwakeable aid ("ok" :: Text)+        Right again <- Store.runStoreIO storeHandle $ signalAwakeable aid ("later" :: Text)+        again `shouldBe` False+        Right (Just row) <- Store.runStoreIO storeHandle $ Awk.lookupAwakeable (awakeableIdToUuid aid)+        row ^. #payload `shouldBe` Just (toJSON ("ok" :: Text))+        Right recorded <-+          Store.runStoreIO storeHandle $+            Store.readStreamForward (StreamName "wf:idem-wf-i") (StreamVersion 0) 100+        Right decoded <- pure (traverse (decodeRecorded workflowJournalCodec) (Vector.toList recorded))+        [r | StepRecorded s r _ <- decoded, s == awkStep] `shouldBe` [toJSON ("ok" :: Text)]++      it "throws WorkflowAwakeableCancelled after cancelAwakeable" $ \storeHandle -> do+        aidRef <- newIORef Nothing+        let name = WorkflowName "cancelwf"+            wid = WorkflowId "wf2"+        Right Suspended <- Store.runStoreIO storeHandle $ runWorkflow name wid (approvalFlowWithId aidRef)+        aid <- readRequiredAwakeableId aidRef+        Right cancelled <- Store.runStoreIO storeHandle $ cancelAwakeable aid+        cancelled `shouldBe` True+        Right (Just row) <- Store.runStoreIO storeHandle $ Awk.lookupAwakeable (awakeableIdToUuid aid)+        row ^. #status `shouldBe` Awk.Cancelled+        Store.runStoreIO storeHandle (runWorkflow name wid (approvalFlowWithId aidRef))+          `shouldThrow` (== WorkflowAwakeableCancelled aid)+        Right recorded <-+          Store.runStoreIO storeHandle $+            Store.readStreamForward (StreamName "wf:cancelwf-wf2") (StreamVersion 0) 100+        Right decoded <- pure (traverse (decodeRecorded workflowJournalCodec) (Vector.toList recorded))+        any (\case WorkflowCompleted {} -> True; _ -> False) decoded `shouldBe` False++      it "re-appends a missing journal entry when re-signalled (crash-safe)" $ \storeHandle -> do+        aidRef <- newIORef Nothing+        let name = WorkflowName "crash"+            wid = WorkflowId "wf3"+        Right Suspended <- Store.runStoreIO storeHandle $ runWorkflow name wid (approvalFlowWithId aidRef)+        aid <- readRequiredAwakeableId aidRef+        let awkStep = "awk:" <> awakeableIdText aid+        -- Simulate "row completed but the journal append did not happen" by+        -- completing the row directly, bypassing signalAwakeable's journal write.+        now <- getCurrentTime+        Right completedRow <-+          Store.runStoreIO storeHandle $+            Store.runTransaction $+              Awk.completeAwakeableTx (awakeableIdToUuid aid) (toJSON ("ok" :: Text)) now+        completedRow `shouldBe` True+        Right beforeRepair <-+          Store.runStoreIO storeHandle $+            Store.readStreamForward (StreamName "wf:crash-wf3") (StreamVersion 0) 100+        Right beforeDecoded <- pure (traverse (decodeRecorded workflowJournalCodec) (Vector.toList beforeRepair))+        [() | StepRecorded s _ _ <- beforeDecoded, s == awkStep] `shouldBe` []+        -- A re-signal with the same payload returns False (already completed) but+        -- repairs the missing journal entry from the stored payload.+        Right repaired <- Store.runStoreIO storeHandle $ signalAwakeable aid ("ok" :: Text)+        repaired `shouldBe` False+        Right afterRepair <-+          Store.runStoreIO storeHandle $+            Store.readStreamForward (StreamName "wf:crash-wf3") (StreamVersion 0) 100+        Right afterDecoded <- pure (traverse (decodeRecorded workflowJournalCodec) (Vector.toList afterRepair))+        [r | StepRecorded s r _ <- afterDecoded, s == awkStep] `shouldBe` [toJSON ("ok" :: Text)]++      it "repairs a completed awakeable row from the await arm without a second signal" $ \storeHandle -> do+        aidRef <- newIORef Nothing+        let name = WorkflowName "crash-arm"+            wid = WorkflowId "wf4"+        Right Suspended <- Store.runStoreIO storeHandle $ runWorkflow name wid (approvalFlowWithId aidRef)+        aid <- readRequiredAwakeableId aidRef+        let awkStep = "awk:" <> awakeableIdText aid+        now <- getCurrentTime+        Right True <-+          Store.runStoreIO storeHandle $+            Store.runTransaction $+              Awk.completeAwakeableTx (awakeableIdToUuid aid) (toJSON ("ok" :: Text)) now+        repairedRun <- Store.runStoreIO storeHandle $ runWorkflow name wid (approvalFlowWithId aidRef)+        repairedRun `shouldBe` Right Suspended+        Right repairedJournal <-+          Store.runStoreIO storeHandle $+            Store.readStreamForward (StreamName "wf:crash-arm-wf4") (StreamVersion 0) 100+        Right repairedDecoded <- pure (traverse (decodeRecorded workflowJournalCodec) (Vector.toList repairedJournal))+        [r | StepRecorded s r _ <- repairedDecoded, s == awkStep] `shouldBe` [toJSON ("ok" :: Text)]+        completed <- Store.runStoreIO storeHandle $ runWorkflow name wid (approvalFlowWithId aidRef)+        completed `shouldBe` Right (Completed "ok!")++      it "refuses a forged coordinate-derived id for a fresh awakeable" $ \storeHandle -> do+        aidRef <- newIORef Nothing+        let name = WorkflowName "fresh-awake"+            wid = WorkflowId "fa-1"+            forged = deterministicAwakeableId name wid "approval"+        Right Suspended <- Store.runStoreIO storeHandle $ runWorkflow name wid (approvalFlowWithId aidRef)+        real <- readRequiredAwakeableId aidRef+        real `shouldNotBe` forged+        Right forgedSignal <- Store.runStoreIO storeHandle $ signalAwakeable forged ("bad" :: Text)+        forgedSignal `shouldBe` False+        Right stillSuspended <- Store.runStoreIO storeHandle $ runWorkflow name wid (approvalFlowWithId aidRef)+        stillSuspended `shouldBe` Suspended+        Right realSignal <- Store.runStoreIO storeHandle $ signalAwakeable real ("ok" :: Text)+        realSignal `shouldBe` True+        completed <- Store.runStoreIO storeHandle $ runWorkflow name wid (approvalFlowWithId aidRef)+        completed `shouldBe` Right (Completed "ok!")++      it "adopts a generation-0 legacy deterministic row" $ \storeHandle -> do+        aidRef <- newIORef Nothing+        let name = WorkflowName "legacy-awake"+            wid = WorkflowId "la-1"+            legacy = deterministicAwakeableId name wid "approval"+        Right () <-+          Store.runStoreIO storeHandle $+            Store.runTransaction $+              Awk.registerAwakeableTx (awakeableIdToUuid legacy) (unWorkflowName name) (unWorkflowId wid)+        Right Suspended <- Store.runStoreIO storeHandle $ runWorkflow name wid (approvalFlowWithId aidRef)+        adopted <- readRequiredAwakeableId aidRef+        adopted `shouldBe` legacy+        Right True <- Store.runStoreIO storeHandle $ signalAwakeable legacy ("ok" :: Text)+        completed <- Store.runStoreIO storeHandle $ runWorkflow name wid (approvalFlowWithId aidRef)+        completed `shouldBe` Right (Completed "ok!")++      it "allocates a fresh awakeable for the same label after continueAsNew" $ \storeHandle -> do+        idsRef <- newIORef []+        let name = WorkflowName "awake-roll"+            wid = WorkflowId "ar-1"+            body = rollingAwakeableWorkflow idsRef+        Right Suspended <- Store.runStoreIO storeHandle $ runWorkflow name wid body+        ids1 <- readIORef idsRef+        [firstAid] <- pure ids1+        Right True <- Store.runStoreIO storeHandle $ signalAwakeable firstAid ("first" :: Text)+        Right ContinuedAsNew <- Store.runStoreIO storeHandle $ runWorkflow name wid body+        Right Suspended <- Store.runStoreIO storeHandle $ runWorkflow name wid body+        ids2 <- readIORef idsRef+        case ids2 of+          [firstAgain, secondAid] -> do+            firstAgain `shouldBe` firstAid+            secondAid `shouldNotBe` firstAid+            Right staleSignal <- Store.runStoreIO storeHandle $ signalAwakeable firstAid ("stale" :: Text)+            staleSignal `shouldBe` False+            Right stillSuspended <- Store.runStoreIO storeHandle $ runWorkflow name wid body+            stillSuspended `shouldBe` Suspended+            Right True <- Store.runStoreIO storeHandle $ signalAwakeable secondAid ("second" :: Text)+            completed <- Store.runStoreIO storeHandle $ runWorkflow name wid body+            completed `shouldBe` Right (Completed "second")+          other -> expectationFailure ("expected two awakeable ids, got " <> show other)++  describe "Keiro.Workflow 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++-- | 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.+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 <> "!"))++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)++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 ())++-- | A two-step child workflow used in the child-workflow tests.+shipWorkflow :: (Workflow :> es) => Eff es Text+shipWorkflow = do+  a <- step (StepName "pack") (pure ("packed" :: Text))+  b <- step (StepName "label") (pure (a <> "+labelled"))+  pure b++-- | A parent that spawns a @"ship"@ child (id supplied), awaits its result, and+-- then records a @notify@ step. Parametrised by child id so each test isolates+-- its own child journal.+parentWorkflow :: (Workflow :> es, Store :> es, IOE :> es) => WorkflowId -> Eff es Text+parentWorkflow childWid = do+  h <- spawnChild (WorkflowName "ship") childWid shipWorkflow+  result <- awaitChild h+  _ <- step (StepName "notify") (pure ("done:" <> result))+  pure ("done:" <> result)++jsonObjectChildWorkflow :: Eff es Aeson.Value+jsonObjectChildWorkflow =+  pure (object ["cancelled" Aeson..= True])++jsonObjectParentWorkflow :: (Workflow :> es, Store :> es, IOE :> es) => WorkflowId -> Eff es Aeson.Value+jsonObjectParentWorkflow childWid = do+  h <- spawnChild (WorkflowName "json-child") childWid jsonObjectChildWorkflow+  result <- awaitChild h+  _ <- step (StepName "json-notify") (pure ())+  pure result++selfCancellingWorkflow :: (Workflow :> es, Store :> es, IOE :> es) => WorkflowName -> WorkflowId -> IORef Int -> Eff es Int+selfCancellingWorkflow name wid counter = do+  _ <- step (StepName "one") (liftIO (incrementAndRead counter))+  _ <-+    step (StepName "two") $ do+      now <- liftIO getCurrentTime+      appendJournalEntry name wid (WorkflowCancelled now)+      liftIO (incrementAndRead counter)+  step (StepName "three") (liftIO (incrementAndRead counter))++nominalDays :: Int -> NominalDiffTime+nominalDays n = fromIntegral n * 86400++attrKeyText :: AttributeKey Text -> Text+attrKeyText = unkey++attrKeyTextInt64 :: AttributeKey Int64 -> Text+attrKeyTextInt64 = unkey++textAttr :: Attributes -> Text -> Maybe Text+textAttr attrs name = case lookupAttribute attrs name of+  Just (AttributeValue (TextAttribute t)) -> Just t+  _ -> Nothing++intAttr :: Attributes -> Text -> Maybe Int64+intAttr attrs name = case lookupAttribute attrs name of+  Just (AttributeValue (IntAttribute n)) -> Just n+  _ -> Nothing++-- | A frozen snapshot of an 'ImmutableSpan'. In hs-opentelemetry 1.0 the+-- mutable span fields (name, attributes, status) live behind the+-- @spanHot :: IORef SpanHot@ field rather than directly on 'ImmutableSpan',+-- so the tests read that reference once after the span ends and assert on+-- this flat record.+data CapturedSpan = CapturedSpan+  { csName :: Text,+    csKind :: SpanKind,+    csAttributes :: Attributes,+    csStatus :: SpanStatus,+    csContext :: SpanContext,+    csParent :: Maybe Span+  }++captureSpan :: ImmutableSpan -> IO CapturedSpan+captureSpan sp = do+  hot <- readIORef (spanHot sp)+  pure+    CapturedSpan+      { csName = hotName hot,+        csKind = spanKind sp,+        csAttributes = hotAttributes hot,+        csStatus = hotStatus hot,+        csContext = spanContext sp,+        csParent = spanParent sp+      }++-- | Tiny in-process \"Kafka topic\": an MVar of consumed records plus an+-- incrementing offset. The publisher pushes records here; the consumer+-- drains the MVar. There is no real broker — the goal of the fixture is+-- to validate that the keiro envelope and outbox/inbox semantics+-- compose correctly across two isolated PostgreSQL contexts.+newtype KafkaTopic = KafkaTopic (MVar (Int64, [InboxKafka.KafkaInboundRecord]))++newKafkaTopic :: IO KafkaTopic+newKafkaTopic = KafkaTopic <$> newMVar (0, [])++kafkaTopicAccept :: (MonadIO m) => KafkaTopic -> OutboxRow -> m ()+kafkaTopicAccept (KafkaTopic ref) row = liftIO $ do+  let record = OutboxKafka.outboxRowToKafkaRecord row+      headersText =+        [ (TE.decodeUtf8 name, TE.decodeUtf8 value)+        | (name, value) <- record ^. #headers+        ]+  now <- getCurrentTime+  modifyMVar ref $ \(nextOffset, acc) ->+    let inbound =+          InboxKafka.KafkaInboundRecord+            { topic = record ^. #topic,+              partition = 0,+              offset = nextOffset,+              key = fmap TE.decodeUtf8 (record ^. #key),+              payload = record ^. #payload,+              headers = headersText,+              receivedAt = now+            }+     in pure ((nextOffset + 1, inbound : acc), ())++kafkaTopicPublish ::+  forall es.+  (IOE :> es) =>+  KafkaTopic ->+  OutboxRow ->+  Eff es PublishOutcome+kafkaTopicPublish topic row = do+  kafkaTopicAccept topic row+  pure PublishSucceeded++perRow ::+  (OutboxRow -> Eff es PublishOutcome) ->+  [OutboxRow] ->+  Eff es [(OutboxId, PublishOutcome)]+perRow publish rows =+  traverse publishOne rows+  where+    publishOne row = do+      outcome <- publish row+      pure (row ^. #outboxId, outcome)++drainKafkaTopic :: KafkaTopic -> IO [InboxKafka.KafkaInboundRecord]+drainKafkaTopic (KafkaTopic ref) = do+  (_, acc) <- readMVar ref+  pure (reverse acc)++redeliverWithDifferentOffset ::+  InboxKafka.KafkaInboundRecord ->+  InboxKafka.KafkaInboundRecord+redeliverWithDifferentOffset record = record & #offset .~ (record ^. #offset) + 1000++data ConsumeResult a+  = ConsumeDecodeFailed !InboxKafka.KafkaDecodeError+  | ConsumePolicyUnsatisfied !InboxError+  | ConsumeApplied !(InboxResult a)+  deriving stock (Eq, Show)++-- | A worker-shaped consumer: decode the Kafka record into an+-- IntegrationEvent and run it through the inbox.+consumeAndApply ::+  forall es.+  (IOE :> es, Store :> es) =>+  InboxKafka.KafkaInboundRecord ->+  (IntegrationEvent -> Tx.Transaction ()) ->+  Eff es (ConsumeResult ())+consumeAndApply record handler =+  case InboxKafka.integrationEventFromKafka record of+    Left err -> pure (ConsumeDecodeFailed err)+    Right (event, kafkaRef) -> do+      result <-+        runInboxTransaction Nothing PreferIntegrationMessageId event (Just kafkaRef) handler+      case result of+        Left err -> pure (ConsumePolicyUnsatisfied err)+        Right applied -> pure (ConsumeApplied applied)++billingReactionHandler :: IntegrationEvent -> Tx.Transaction ()+billingReactionHandler event = case decodeJsonIntegrationEvent event of+  Left _ -> Tx.condemn+  Right (OrderSubmittedPayload orderId quantity) ->+    Tx.statement (orderId, fromIntegral quantity :: Int64) insertReceivedOrderStmt++loggingReactionHandler :: Text -> IntegrationEvent -> Tx.Transaction ()+loggingReactionHandler _ event = do+  -- The cross-context test only needs the (eventType, key) pair, not+  -- the decoded payload.+  let key = fromMaybe "" (event ^. #key)+  Tx.statement (event ^. #source, event ^. #eventType, key) appendBillingEventLogStmt++insertReceivedOrderStmt :: Statement (Text, Int64) ()+insertReceivedOrderStmt =+  preparable+    """+    INSERT INTO billing_received_orders (order_id, quantity) VALUES ($1, $2)+    ON CONFLICT (order_id) DO NOTHING+    """+    ( contrazip2+        (E.param (E.nonNullable E.text))+        (E.param (E.nonNullable E.int8))+    )+    D.noResult++billingReceivedOrdersCountStmt :: Statement () Int+billingReceivedOrdersCountStmt =+  preparable+    "SELECT COUNT(*)::bigint FROM billing_received_orders"+    E.noParams+    (D.singleRow (fromIntegral <$> D.column (D.nonNullable D.int8)))++appendBillingEventLogStmt :: Statement (Text, Text, Text) ()+appendBillingEventLogStmt =+  preparable+    "INSERT INTO billing_event_log (source, event_type, order_id) VALUES ($1, $2, $3)"+    ( contrazip3+        (E.param (E.nonNullable E.text))+        (E.param (E.nonNullable E.text))+        (E.param (E.nonNullable E.text))+    )+    D.noResult++billingEventLogStmt :: Statement () [(Text, Text)]+billingEventLogStmt =+  preparable+    "SELECT event_type, order_id FROM billing_event_log ORDER BY seq"+    E.noParams+    ( D.rowList+        ( (,)+            <$> D.column (D.nonNullable D.text)+            <*> D.column (D.nonNullable D.text)+        )+    )++orderSubmittedEnvelope :: Text -> Int -> Text -> IntegrationEvent+orderSubmittedEnvelope orderId quantity messageId =+  encodeJsonIntegrationEvent+    ( sampleIntegrationEnvelope+        & #messageId+        .~ messageId+        & #eventType+        .~ "OrderSubmitted"+        & #key+        .~ Just orderId+    )+    (OrderSubmittedPayload orderId quantity)++orderCancelledEnvelope :: Text -> Text -> IntegrationEvent+orderCancelledEnvelope orderId messageId =+  sampleIntegrationEnvelope+    & #messageId+    .~ messageId+    & #eventType+    .~ "OrderCancelled"+    & #key+    .~ Just orderId+    & #payloadBytes+    .~ ("{\"orderId\":\"" <> TE.encodeUtf8 orderId <> "\"}")+    & #contentType+    .~ ApplicationJson++inboxTestCounterInsertStmt :: Statement Text ()+inboxTestCounterInsertStmt =+  preparable+    "INSERT INTO inbox_test_counter (message_id) VALUES ($1)"+    (E.param (E.nonNullable E.text))+    D.noResult++inboxTestCounterCountStmt :: Statement () Int+inboxTestCounterCountStmt =+  preparable+    "SELECT COUNT(*)::bigint FROM inbox_test_counter"+    E.noParams+    (D.singleRow (fromIntegral <$> D.column (D.nonNullable D.int8)))++sampleProducer :: IntegrationProducer ()+sampleProducer =+  IntegrationProducer+    { name = "ordering-integration-producer",+      source = "ordering",+      messageIdPrefix = "msg",+      mapEvent = \_recorded () -> Just sampleDraft+    }++sampleDraft :: IntegrationEventDraft+sampleDraft =+  IntegrationEventDraft+    { destination = "billing.orders.v1",+      key = Just "order-123",+      eventType = "OrderSubmitted",+      schemaVersion = 1,+      contentType = ApplicationJson,+      schemaReference = Nothing,+      sourceEventId = Nothing,+      sourceGlobalPosition = Nothing,+      payloadBytes = "{\"orderId\":\"order-123\",\"quantity\":5}",+      occurredAt = UTCTime (ModifiedJulianDay 60000) (secondsToDiffTime 0),+      causationId = Nothing,+      correlationId = Nothing,+      traceContext = Nothing,+      attributes = Just (object ["source" Aeson..= ("test-suite" :: Text)])+    }++sampleOutboxRow :: IntegrationEvent -> OutboxRow+sampleOutboxRow event =+  OutboxRow+    { outboxId = OutboxId outboxUuid1,+      event,+      status = OutboxPending,+      attemptCount = 0,+      nextAttemptAt = UTCTime (ModifiedJulianDay 60000) (secondsToDiffTime 0),+      lastError = Nothing,+      publishedAt = Nothing,+      createdAt = UTCTime (ModifiedJulianDay 60000) (secondsToDiffTime 0),+      updatedAt = UTCTime (ModifiedJulianDay 60000) (secondsToDiffTime 0)+    }++backdateOutboxUpdatedAt :: (Store :> es) => OutboxId -> UTCTime -> Eff es ()+backdateOutboxUpdatedAt oid timestamp =+  Store.runTransaction $+    Tx.statement (unOutboxId oid, timestamp) backdateOutboxUpdatedAtStmt++backdateOutboxUpdatedAtStmt :: Statement (UUID, UTCTime) ()+backdateOutboxUpdatedAtStmt =+  preparable+    "UPDATE keiro.keiro_outbox SET updated_at = $2 WHERE outbox_id = $1"+    ( contrazip2+        (E.param (E.nonNullable E.uuid))+        (E.param (E.nonNullable E.timestamptz))+    )+    D.noResult++backdateOutboxPublishedAt :: (Store :> es) => OutboxId -> UTCTime -> Eff es ()+backdateOutboxPublishedAt oid timestamp =+  Store.runTransaction $+    Tx.statement (unOutboxId oid, timestamp) backdateOutboxPublishedAtStmt++backdateOutboxPublishedAtStmt :: Statement (UUID, UTCTime) ()+backdateOutboxPublishedAtStmt =+  preparable+    "UPDATE keiro.keiro_outbox SET published_at = $2 WHERE outbox_id = $1"+    ( contrazip2+        (E.param (E.nonNullable E.uuid))+        (E.param (E.nonNullable E.timestamptz))+    )+    D.noResult++outboxUuid1, outboxUuid2, outboxUuid3, outboxUuid4 :: UUID+outboxUuid1 = case fromString "018f0f18-0000-7000-8000-000000000a01" of+  Just uuid -> uuid+  Nothing -> error "invalid outbox uuid 1"+outboxUuid2 = case fromString "018f0f18-0000-7000-8000-000000000a02" of+  Just uuid -> uuid+  Nothing -> error "invalid outbox uuid 2"+outboxUuid3 = case fromString "018f0f18-0000-7000-8000-000000000a03" of+  Just uuid -> uuid+  Nothing -> error "invalid outbox uuid 3"+outboxUuid4 = case fromString "018f0f18-0000-7000-8000-000000000a04" of+  Just uuid -> uuid+  Nothing -> error "invalid outbox uuid 4"++outboxIdFromOrdinal :: Word64 -> OutboxId+outboxIdFromOrdinal n =+  OutboxId (fromWords64 0x018f0f1800007000 (0x8000000000000000 + n))++uniqueIds :: (Eq a) => [a] -> [a]+uniqueIds = foldr (\x xs -> if x `elem` xs then xs else x : xs) []++data OrderSubmittedPayload = OrderSubmittedPayload+  { orderId :: !Text,+    quantity :: !Int+  }+  deriving stock (Generic, Eq, Show)++instance ToJSON OrderSubmittedPayload where+  toJSON = genericToJSON (aesonPrefix camelCase)+  toEncoding = genericToEncoding (aesonPrefix camelCase)++instance FromJSON OrderSubmittedPayload where+  parseJSON = genericParseJSON (aesonPrefix camelCase)++sampleIntegrationEnvelope :: IntegrationEvent+sampleIntegrationEnvelope =+  IntegrationEvent+    { messageId = "018f0f18-17aa-7000-8000-0000000000aa",+      source = "ordering",+      destination = "billing.orders.v1",+      key = Just "order-123",+      eventType = "OrderSubmitted",+      schemaVersion = 1,+      contentType = ApplicationJson,+      schemaReference =+        Just+          SchemaReference+            { registry = Just "https://schemas.example/registry",+              subject = Just "billing.orders.v1.OrderSubmitted",+              version = Just 1,+              schemaId = Just 42,+              fingerprint = Just "sha256:abc123"+            },+      sourceEventId = Just (EventId integrationSourceEventUuid),+      sourceGlobalPosition = Just (GlobalPosition 42),+      payloadBytes = "{\"orderId\":\"order-123\",\"quantity\":5}",+      occurredAt = UTCTime (ModifiedJulianDay 60000) (secondsToDiffTime 0),+      causationId = Just (EventId integrationCausationUuid),+      correlationId = Just (EventId integrationCorrelationUuid),+      traceContext =+        Just+          TraceContext+            { traceparent = "00-0af7651916cd43dd8448eb211c80319c-b7ad6b7169203331-01",+              tracestate = Just "rojo=00f067aa0ba902b7"+            },+      attributes = Nothing+    }++integrationSourceEventUuid :: UUID+integrationSourceEventUuid =+  case fromString "018f0f18-17aa-7000-8000-000000000003" of+    Just uuid -> uuid+    Nothing -> error "invalid integration source event UUID"++integrationCausationUuid :: UUID+integrationCausationUuid =+  case fromString "018f0f18-17aa-7000-8000-000000000004" of+    Just uuid -> uuid+    Nothing -> error "invalid integration causation UUID"++integrationCorrelationUuid :: UUID+integrationCorrelationUuid =+  case fromString "018f0f18-17aa-7000-8000-000000000005" of+    Just uuid -> uuid+    Nothing -> error "invalid integration correlation UUID"++data OrderStream++data OrderEvent+  = OrderPlaced !Text !Int+  deriving stock (Generic, Eq, Show)++data OrderState+  = Idle+  deriving stock (Generic, Eq, Show)++data OrderCommand+  = PlaceOrder+  deriving stock (Generic, Eq, Show)++orderCodec :: Codec OrderEvent+orderCodec =+  Codec+    { eventTypes = EventType "OrderPlaced" :| [],+      eventType = \case+        OrderPlaced {} -> EventType "OrderPlaced",+      schemaVersion = 2,+      encode = \case+        OrderPlaced orderId quantity ->+          object ["orderId" Aeson..= orderId, "quantity" Aeson..= quantity],+      decode = parseOrderPlaced,+      upcasters = [(1, const upcastOrderPlacedV1)]+    }++gappyCodec :: Codec OrderEvent+gappyCodec =+  Codec+    { eventTypes = orderCodec ^. #eventTypes,+      eventType = orderCodec ^. #eventType,+      schemaVersion = 4,+      encode = orderCodec ^. #encode,+      decode = orderCodec ^. #decode,+      upcasters = [(1, const upcastOrderPlacedV1), (3, const Right)]+    }++parseOrderPlaced :: EventType -> Value -> Either Text OrderEvent+parseOrderPlaced _ value =+  case parseEither parser value of+    Right event -> Right event+    Left message -> Left (fromStringLiteral message)+  where+    parser = withObject "OrderPlaced" $ \objectValue ->+      OrderPlaced+        <$> objectValue .: "orderId"+        <*> objectValue .: "quantity"++upcastOrderPlacedV1 :: Value -> Either Text Value+upcastOrderPlacedV1 value =+  case parseEither parser value of+    Right migrated -> Right migrated+    Left message -> Left (fromStringLiteral message)+  where+    parser = withObject "OrderPlacedV1" $ \objectValue -> do+      orderId <- objectValue .: "orderId"+      quantity <- objectValue .: "qty"+      pure (object ["orderId" Aeson..= (orderId :: Text), "quantity" Aeson..= (quantity :: Int)])++metadataForOrDie :: Int -> Maybe Value -> Value+metadataForOrDie version existing =+  either (error . show) id (metadataFor version existing)++emptyTransducer :: SymTransducer () '[] OrderState OrderCommand OrderEvent+emptyTransducer =+  SymTransducer+    { edgesOut = \_ -> [],+      initial = Idle,+      initialRegs = RNil,+      isFinal = \_ -> True+    }++type CounterEventStream = EventStream (HsPred '[] CounterCommand) '[] CounterState CounterCommand CounterEvent++type ValidatedCounterEventStream = ValidatedEventStream (HsPred '[] CounterCommand) '[] CounterState CounterCommand CounterEvent++type SnapshotCounterRegs = '[ '("lastAmount", Int)]++type UninitializedSnapshotRegs = '[ '("initialized", Int), '("neverWritten", Int)]++type SnapshotCounterEventStream = EventStream (HsPred SnapshotCounterRegs CounterCommand) SnapshotCounterRegs CounterState CounterCommand CounterEvent++type PartialSnapshotEventStream = EventStream (HsPred SnapshotCounterRegs CounterCommand) SnapshotCounterRegs PartialSnapshotState CounterCommand CounterEvent++type ValidatedSnapshotCounterEventStream = ValidatedEventStream (HsPred SnapshotCounterRegs CounterCommand) SnapshotCounterRegs CounterState CounterCommand CounterEvent++type UninitializedSnapshotEventStream = EventStream (HsPred UninitializedSnapshotRegs CounterCommand) UninitializedSnapshotRegs CounterState CounterCommand CounterEvent++data CounterCommand+  = Add !Int+  deriving stock (Generic, Eq, Show)++data SkipCommand+  = SAdd !Int+  | SSkip+  deriving stock (Generic, Eq, Show)++data CounterEvent+  = CounterAdded !Int+  | CounterAudited !Int+  deriving stock (Generic, Eq, Show)++data CounterState+  = Counting+  deriving stock (Generic, Eq, Show, Enum, Bounded, Ord)+  deriving anyclass (FromJSON, ToJSON)++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++skipEventStream :: ValidatedSkipEventStream+skipEventStream = mkEventStreamOrThrow "skip-command" skipEventStreamDef++skipEventStreamDef :: SkipEventStream+skipEventStreamDef =+  EventStream+    { transducer = skipTransducer,+      initialState = Counting,+      initialRegisters = RNil,+      eventCodec = counterCodec,+      resolveStreamName = Stream.streamName,+      snapshotPolicy = Never,+      stateCodec = Nothing+    }++skipTransducer :: SymTransducer (HsPred '[] SkipCommand) '[] CounterState SkipCommand CounterEvent+skipTransducer =+  SymTransducer+    { edgesOut = \case+        Counting ->+          [ Edge+              { guard = matchInCtor sAddCtor,+                update = UKeep,+                output = [pack sAddCtor counterAddedCtor (inpCtor sAddCtor #amount *: oNil)],+                target = Counting,+                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 =+  InCtor+    { icName = "SAdd",+      icMatch = \case+        SAdd amount -> Just (RCons Proxy amount RNil)+        SSkip -> Nothing,+      icBuild = \case+        RCons _ amount RNil -> SAdd amount+    }++sSkipCtor :: InCtor SkipCommand '[]+sSkipCtor =+  InCtor+    { icName = "SSkip",+      icMatch = \case+        SAdd {} -> Nothing+        SSkip -> Just RNil,+      icBuild = \case+        RNil -> SSkip+    }++addCtor :: InCtor CounterCommand AddFields+addCtor =+  InCtor+    { icName = "Add",+      icMatch = \case+        Add amount -> Just (RCons Proxy amount RNil),+      icBuild = \case+        RCons _ amount RNil -> Add amount+    }++counterAddedCtor :: WireCtor CounterEvent (Int, ())+counterAddedCtor =+  WireCtor+    { wcName = "CounterAdded",+      wcMatch = \case+        CounterAdded amount -> Just (amount, ())+        CounterAudited {} -> Nothing,+      wcBuild = \case+        (amount, ()) -> CounterAdded amount+    }++counterAuditedCtor :: WireCtor CounterEvent (Int, ())+counterAuditedCtor =+  WireCtor+    { wcName = "CounterAudited",+      wcMatch = \case+        CounterAudited amount -> Just (amount, ())+        CounterAdded {} -> Nothing,+      wcBuild = \case+        (amount, ()) -> CounterAudited amount+    }++counterCodec :: Codec CounterEvent+counterCodec =+  Codec+    { eventTypes = EventType "CounterAdded" :| [EventType "CounterAudited"],+      eventType = \case+        CounterAdded {} -> EventType "CounterAdded"+        CounterAudited {} -> EventType "CounterAudited",+      schemaVersion = 1,+      encode = \case+        CounterAdded amount -> object ["amount" Aeson..= amount]+        CounterAudited amount -> object ["amount" Aeson..= amount, "audited" Aeson..= True],+      decode = parseCounterEvent,+      upcasters = []+    }++parseCounterEvent :: EventType -> Value -> Either Text CounterEvent+parseCounterEvent (EventType tag) value =+  case parseEither parser value of+    Right event -> Right event+    Left message -> Left (fromStringLiteral message)+  where+    parser = withObject "CounterEvent" $ \objectValue -> do+      amount <- objectValue .: "amount"+      case tag of+        "CounterAdded" -> pure (CounterAdded amount)+        "CounterAudited" -> pure (CounterAudited amount)+        _ -> fail "unknown counter event type"++-- * 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 =+  InCtor+    { icName = "ConfirmDivert",+      icMatch = \case+        ConfirmDivert acuityBlack -> Just (RCons Proxy acuityBlack RNil),+      icBuild = \case+        RCons _ acuityBlack RNil -> ConfirmDivert acuityBlack+    }++divertConfirmedCtor :: WireCtor DivertEvent (Bool, ())+divertConfirmedCtor =+  WireCtor+    { wcName = "DivertConfirmed",+      wcMatch = \case+        DivertConfirmed acuityBlack -> Just (acuityBlack, ()),+      wcBuild = \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+        ]+    )++counterProcessManager ::+  ProcessManager+    CounterEvent+    (HsPred '[] CounterCommand)+    '[]+    CounterState+    CounterCommand+    CounterEvent+    (HsPred '[] CounterCommand)+    '[]+    CounterState+    CounterCommand+    CounterEvent+counterProcessManager =+  ProcessManager+    { name = "counter-pm",+      correlate = \_ -> "order-1",+      eventStream = counterEventStream,+      streamFor = \correlationId -> stream ("pm:counter-" <> correlationId),+      targetEventStream = counterEventStream,+      targetProjections = const [],+      handle = \case+        CounterAdded amount ->+          ProcessManagerAction+            { command = Add amount,+              commands =+                [ PMCommand+                    { target = stream "counter-target-order-1",+                      command = Add amount+                    }+                ],+              timers = [counterTimerRequest]+            }+        CounterAudited amount ->+          ProcessManagerAction+            { command = Add amount,+              commands = [],+              timers = []+            }+    }++timerOnlyProcessManager ::+  ProcessManager+    CounterEvent+    (HsPred '[] CounterCommand)+    '[]+    CounterState+    CounterCommand+    CounterEvent+    (HsPred '[] CounterCommand)+    '[]+    CounterState+    CounterCommand+    CounterEvent+timerOnlyProcessManager =+  ProcessManager+    { name = "timer-only-pm",+      correlate = \_ -> "order-1",+      eventStream = noOpCounterEventStream,+      streamFor = \correlationId -> stream ("pm:timer-only-" <> correlationId),+      targetEventStream = counterEventStream,+      targetProjections = const [],+      handle = \case+        CounterAdded amount ->+          ProcessManagerAction+            { command = Add amount,+              commands = [],+              timers =+                [ counterTimerRequest+                    & #processManagerName+                    .~ "timer-only-pm"+                ]+            }+        CounterAudited amount ->+          ProcessManagerAction+            { command = Add amount,+              commands = [],+              timers = []+            }+    }++-- A process manager whose OWN state stream snapshots under Every 2.+-- This is the first PM fixture to exercise a state-stream snapshot: the only+-- difference from counterProcessManager is that its eventStream carries a+-- snapshotPolicy + stateCodec (it reuses snapshotCounterEventStream), so+-- runProcessManagerOnce's manager-state append (which goes through+-- runCommandWithSql) writes and reuses snapshots. The manager registers are+-- SnapshotCounterRegs because the eventStream is a SnapshotCounterEventStream;+-- the target side stays '[]/counterEventStream exactly as counterProcessManager.+pmSnapshotCounterEventStreamDef :: SnapshotCounterEventStream+pmSnapshotCounterEventStreamDef = snapshotCounterEventStreamDef++pmSnapshotCounterEventStream :: ValidatedSnapshotCounterEventStream+pmSnapshotCounterEventStream = mkEventStreamOrThrow "pm-snapshot-counter" pmSnapshotCounterEventStreamDef++pmSnapshotProcessManager ::+  ProcessManager+    CounterEvent+    (HsPred SnapshotCounterRegs CounterCommand)+    SnapshotCounterRegs+    CounterState+    CounterCommand+    CounterEvent+    (HsPred '[] CounterCommand)+    '[]+    CounterState+    CounterCommand+    CounterEvent+pmSnapshotProcessManager =+  ProcessManager+    { name = "counter-snap-pm",+      correlate = \_ -> "order-1",+      eventStream = pmSnapshotCounterEventStream,+      streamFor = \correlationId -> stream ("pm:counter-snap-" <> correlationId),+      targetEventStream = counterEventStream,+      targetProjections = const [],+      handle = \case+        CounterAdded amount ->+          ProcessManagerAction+            { command = Add amount,+              commands = [], -- keep the test focused on the manager state stream+              timers = []+            }+        CounterAudited amount ->+          ProcessManagerAction+            { command = Add amount,+              commands = [],+              timers = []+            }+    }++workflowProcessManager ::+  Text ->+  Text ->+  Text ->+  ProcessManager+    CounterEvent+    (HsPred '[] CounterCommand)+    '[]+    CounterState+    CounterCommand+    CounterEvent+    (HsPred '[] CounterCommand)+    '[]+    CounterState+    CounterCommand+    CounterEvent+workflowProcessManager managerName managerCategory targetStreamName =+  counterProcessManager+    { name = managerName,+      streamFor = \correlationId -> stream (managerCategory <> "-" <> correlationId),+      handle = \case+        CounterAdded amount ->+          ProcessManagerAction+            { command = Add amount,+              commands =+                [ PMCommand+                    { target = stream targetStreamName,+                      command = Add amount+                    }+                ],+              timers = []+            }+        CounterAudited amount ->+          ProcessManagerAction+            { command = Add amount,+              commands = [],+              timers = []+            }+    }++assertWorkflowProcessManagerAppended ::+  Either+    Store.StoreError+    ( Either+        CommandError+        (ProcessManagerResult CounterEventStream CounterEventStream)+    ) ->+  Expectation+assertWorkflowProcessManagerAppended = \case+  Right (Right pmResult) -> do+    pmResult ^. #managerResult `shouldSatisfy` \case+      PMStateAppended {} -> True+      _ -> False+    pmResult ^. #commandResults `shouldSatisfy` \case+      [PMCommandAppended {}] -> True+      _ -> False+  other -> expectationFailure ("expected workflow process-manager success, got " <> show other)++counterTimerRequest :: TimerRequest+counterTimerRequest =+  TimerRequest+    { timerId = TimerId sampleUuid,+      processManagerName = "counter-pm",+      correlationId = "order-1",+      fireAt = dueTimerTime,+      payload = object ["kind" Aeson..= ("counter-timeout" :: Text)]+    }++dueTimerTime :: UTCTime+dueTimerTime = UTCTime (ModifiedJulianDay 1) (secondsToDiffTime 0)++timerStatusAndErrorStmt :: Statement UUID (Maybe (Text, Maybe Text))+timerStatusAndErrorStmt =+  preparable+    """+    SELECT status, last_error+    FROM keiro.keiro_timers+    WHERE timer_id = $1+    """+    (E.param (E.nonNullable E.uuid))+    (D.rowMaybe ((,) <$> D.column (D.nonNullable D.text) <*> D.column (D.nullable D.text)))++-- | Read a timer's status and JSON payload by id (for the workflow-sleep tests).+sleepTimerStatusStmt :: Statement UUID (Maybe (Text, Value))+sleepTimerStatusStmt =+  preparable+    """+    SELECT status, payload+    FROM keiro.keiro_timers+    WHERE timer_id = $1+    """+    (E.param (E.nonNullable E.uuid))+    (D.rowMaybe ((,) <$> D.column (D.nonNullable D.text) <*> D.column (D.nonNullable D.jsonb)))++-- | Read a timer's fire time by id (for workflow-sleep re-arm tests).+sleepTimerFireAtStmt :: Statement UUID (Maybe UTCTime)+sleepTimerFireAtStmt =+  preparable+    """+    SELECT fire_at+    FROM keiro.keiro_timers+    WHERE timer_id = $1+    """+    (E.param (E.nonNullable E.uuid))+    (D.rowMaybe (D.column (D.nonNullable D.timestamptz)))++recordedFrom :: EventData -> RecordedEvent+recordedFrom event =+  RecordedEvent+    { eventId = EventId sampleUuid,+      eventType = event ^. #eventType,+      streamVersion = StreamVersion 1,+      globalPosition = GlobalPosition 1,+      originalStreamId = StreamId 1,+      originalVersion = StreamVersion 1,+      payload = event ^. #payload,+      metadata = event ^. #metadata,+      causationId = Nothing,+      correlationId = Nothing,+      createdAt = UTCTime (ModifiedJulianDay 0) (secondsToDiffTime 0)+    }++recordedFromEventId :: EventId -> CounterEvent -> RecordedEvent+recordedFromEventId eventId event =+  case encodeForAppend counterCodec event of+    Right encoded -> recordedFrom encoded & #eventId .~ eventId+    Left err -> error ("test fixture failed to encode counter event: " <> show err)++appendCounterEventWithId :: Store.KirokuStore -> StreamName -> EventId -> CounterEvent -> IO ()+appendCounterEventWithId storeHandle streamName eventId event = do+  encoded <- shouldBeRight (encodeForAppend counterCodec event)+  outcome <-+    Store.runStoreIO storeHandle $+      Store.appendToStream streamName NoStream [encoded & #eventId ?~ eventId]+  case outcome of+    Right _ -> pure ()+    Left err -> expectationFailure ("failed to insert concurrent duplicate event: " <> show err)++appendCounterEvents :: Store.KirokuStore -> StreamName -> [CounterEvent] -> IO ()+appendCounterEvents storeHandle destinationStreamName events = do+  encoded <- traverse (shouldBeRight . encodeForAppend counterCodec) events+  outcome <-+    Store.runStoreIO storeHandle $+      Store.appendToStream destinationStreamName NoStream encoded+  case outcome of+    Right _ -> pure ()+    Left err -> expectationFailure ("failed to insert counter events: " <> show err)++-- Insert a real source event and drive Kiroku's acknowledgement bridge to park+-- it in kiroku.dead_letters. A second event lets the test observe that the+-- checkpoint advanced after the dead letter before stopping the subscription.+deadLetterCounterSource :: Store.KirokuStore -> SubscriptionName -> CounterEvent -> IO RecordedEvent+deadLetterCounterSource storeHandle subName sourceEvent = do+  appendCounterEvents+    storeHandle+    (StreamName "counter-replay-source")+    [sourceEvent, CounterAdded 0]+  let subConfig =+        ( KirokuSub.defaultSubscriptionConfig+            subName+            AllStreams+            (\_ -> pure KirokuSub.Continue)+        )+          { KirokuSub.retryPolicy = KirokuSub.RetryPolicy 1+          }+      pull label source = do+        result <- timeout 5_000_000 (Streamly.uncons source)+        case result of+          Just (Just itemAndRest) -> pure itemAndRest+          Just Nothing -> fail (label <> ": subscription ended early")+          Nothing -> fail (label <> ": timed out waiting for delivery")+  (stream0, cancelStream) <- subscriptionAckStream storeHandle subConfig 4+  ( do+      (first, stream1) <- pull "source delivery" stream0+      atomically $+        putTMVar+          (ackReply first)+          (KirokuSub.Retry (KirokuSub.RetryDelay 0))+      (next, stream2) <- pull "event after source dead letter" stream1+      ackEvent next ^. #eventId `shouldNotBe` ackEvent first ^. #eventId+      atomically (putTMVar (ackReply next) KirokuSub.Stop)+      ended <- timeout 5_000_000 (Streamly.uncons stream2)+      case ended of+        Just Nothing -> pure ()+        Just (Just _) -> expectationFailure "replay fixture delivered after Stop"+        Nothing -> expectationFailure "replay fixture did not stop"+      pure (ackEvent first)+    )+    `finally` cancelStream++classifyProcessManagerReplay :: ProcessManagerResult managerTarget commandTarget -> ReplayResult+classifyProcessManagerReplay result =+  case result ^. #managerResult of+    PMStateDuplicate {}+      | Prelude.all commandIsDuplicate (result ^. #commandResults) -> ReplayedDuplicate+    _ -> ReplayedFresh+  where+    commandIsDuplicate = \case+      PMCommandDuplicate {} -> True+      _ -> False++processManagerReplayCounts :: Store.KirokuStore -> IO (Int, Int)+processManagerReplayCounts storeHandle = do+  Right managerEvents <-+    Store.runStoreIO storeHandle $+      Store.readStreamForward (StreamName "pm:counter-order-1") (StreamVersion 0) 10+  Right targetEvents <-+    Store.runStoreIO storeHandle $+      Store.readStreamForward (StreamName "counter-target-order-1") (StreamVersion 0) 10+  pure (Vector.length managerEvents, Vector.length targetEvents)++sampleUuid :: UUID+sampleUuid =+  case fromString "018f0f18-17aa-7000-8000-000000000001" of+    Just uuid -> uuid+    Nothing -> error "invalid test UUID"++sampleUuid2 :: UUID+sampleUuid2 =+  case fromString "018f0f18-17aa-7000-8000-000000000002" of+    Just uuid -> uuid+    Nothing -> error "invalid test UUID"++sampleUuid3 :: UUID+sampleUuid3 =+  case fromString "018f0f18-17aa-7000-8000-000000000003" of+    Just uuid -> uuid+    Nothing -> error "invalid test UUID"++shouldBeRight :: (HasCallStack, Show e) => Either e a -> IO a+shouldBeRight = \case+  Right value -> pure value+  Left err -> expectationFailure ("expected Right, got Left " <> show err) *> error "unreachable"++shouldBeRight_ :: (HasCallStack, Show e) => Either e a -> Expectation+shouldBeRight_ = \case+  Right _ -> pure ()+  Left err -> expectationFailure ("expected Right, got Left " <> show err)++shouldBeLeft :: (HasCallStack, Eq e, Show e) => Either e a -> e -> Expectation+shouldBeLeft actual expected =+  case actual of+    Left err -> err `shouldBe` expected+    Right _ -> expectationFailure ("expected Left " <> show expected <> ", got Right")++fromStringLiteral :: String -> Text+fromStringLiteral = Text.pack++snapshotVersionForStreamStmt :: Statement Text (Maybe StreamVersion)+snapshotVersionForStreamStmt =+  preparable+    """+    SELECT ks.stream_version+    FROM keiro.keiro_snapshots ks+    JOIN streams s ON s.stream_id = ks.stream_id+    WHERE s.stream_name = $1+    """+    (E.param (E.nonNullable E.text))+    (D.rowMaybe (StreamVersion <$> D.column (D.nonNullable D.int8)))++snapshotStateShapeForStreamStmt :: Statement Text (Maybe Text)+snapshotStateShapeForStreamStmt =+  preparable+    """+    SELECT ks.state_shape_hash+    FROM keiro.keiro_snapshots ks+    JOIN streams s ON s.stream_id = ks.stream_id+    WHERE s.stream_name = $1+    """+    (E.param (E.nonNullable E.text))+    (D.rowMaybe (D.column (D.nonNullable D.text)))++corruptSnapshotStateStmt :: Statement (Text, Value) ()+corruptSnapshotStateStmt =+  preparable+    """+    UPDATE keiro.keiro_snapshots ks+    SET state = $2+    FROM streams s+    WHERE s.stream_id = ks.stream_id+      AND s.stream_name = $1+    """+    ( contrazip2+        (E.param (E.nonNullable E.text))+        (E.param (E.nonNullable E.jsonb))+    )+    D.noResult++corruptSnapshotShapeStmt :: Statement (Text, Text) ()+corruptSnapshotShapeStmt =+  preparable+    """+    UPDATE keiro.keiro_snapshots ks+    SET regfile_shape_hash = $2+    FROM streams s+    WHERE s.stream_id = ks.stream_id+      AND s.stream_name = $1+    """+    ( contrazip2+        (E.param (E.nonNullable E.text))+        (E.param (E.nonNullable E.text))+    )+    D.noResult++counterReadModel :: ReadModel Text Int+counterReadModel =+  ReadModel+    { name = "counter-read-model",+      tableName = "counter_read_model",+      schema = "kiroku",+      subscriptionName = "counter-read-model-sub",+      version = 1,+      shapeHash = "counter-read-model-v1",+      defaultConsistency = Eventual,+      strongScope = EntireLog,+      query = \modelId -> Tx.statement modelId selectCounterReadModelStmt+    }++counterCategoryReadModel :: ReadModel Text Int+counterCategoryReadModel =+  counterReadModel & #strongScope .~ CategoryHead "counter"++registerReadModelDefinition :: (Store :> es) => ReadModel q r -> Eff es ()+registerReadModelDefinition readModel =+  void $+    registerReadModel+      (readModel ^. #name)+      (readModel ^. #version)+      (readModel ^. #shapeHash)++initializeRegisteredReadModel ::+  (Store :> es) =>+  ReadModel q r ->+  Tx.Transaction () ->+  Eff es ()+initializeRegisteredReadModel readModel initializeTable = do+  Store.runTransaction initializeTable+  registerReadModelDefinition readModel++counterInlineProjection :: InlineProjection CounterEvent+counterInlineProjection =+  InlineProjection+    { name = "counter-inline-projection",+      apply = \event recorded ->+        case event of+          CounterAdded amount ->+            Tx.statement+              ( "inline",+                Prelude.fromIntegral amount,+                globalPositionToInt (recorded ^. #globalPosition),+                Just (eventIdToUuid (recorded ^. #eventId)),+                metadataActor recorded+              )+              upsertCounterReadModelStmt+          CounterAudited {} -> pure ()+    }++counterAsyncProjection :: AsyncProjection+counterAsyncProjection =+  AsyncProjection+    { name = "counter-async-projection",+      readModelName = "counter-read-model",+      subscriptionName = "counter-read-model-sub",+      applyRecorded = \recorded ->+        case decodeRecorded counterCodec recorded of+          Right (CounterAdded amount) ->+            Tx.statement+              ( "async-idempotent",+                Prelude.fromIntegral amount,+                globalPositionToInt (recorded ^. #globalPosition),+                Just (eventIdToUuid (recorded ^. #eventId)),+                Nothing+              )+              upsertCounterReadModelStmt+          Right CounterAudited {} -> pure ()+          Left _ -> pure (),+      idempotencyKey = \recorded -> recorded ^. #eventId+    }++fastWaitOptions :: PositionWaitOptions+fastWaitOptions =+  PositionWaitOptions+    { target = Nothing,+      timeoutMicros = 50000,+      pollMicros = 5000+    }++initializeCounterReadModelTable :: Tx.Transaction ()+initializeCounterReadModelTable =+  Tx.sql+    """+    CREATE TABLE IF NOT EXISTS counter_read_model (+      model_id TEXT PRIMARY KEY,+      amount BIGINT NOT NULL,+      last_seen BIGINT NOT NULL,+      source_event_id UUID UNIQUE,+      actor TEXT+    )+    """++-- A read model whose data table lives in an application-configured schema+-- (@app_reads@), demonstrating EP-4's configurable projection schema. Its SQL is+-- fully qualified via 'placedTable'; Keiro's own metadata stays in @keiro@.+placedTable :: Text+placedTable = qualifyTable "app_reads" "placed_counter"++placedReadModel :: ReadModel Text Int+placedReadModel =+  ReadModel+    { name = "placed-counter-read-model",+      tableName = "placed_counter",+      schema = "app_reads",+      subscriptionName = "placed-counter-sub",+      version = 1,+      shapeHash = "placed-counter-v1",+      defaultConsistency = Eventual,+      strongScope = EntireLog,+      query = \modelId -> Tx.statement modelId selectPlacedStmt+    }++placedInlineProjection :: InlineProjection CounterEvent+placedInlineProjection =+  InlineProjection+    { name = "placed-inline-projection",+      apply = \event recorded ->+        case event of+          CounterAdded amount ->+            Tx.statement+              ( "placed",+                Prelude.fromIntegral amount,+                globalPositionToInt (recorded ^. #globalPosition)+              )+              upsertPlacedStmt+          CounterAudited {} -> pure ()+    }++initializePlacedTable :: Tx.Transaction ()+initializePlacedTable =+  Tx.sql $+    TE.encodeUtf8 $+      "CREATE TABLE IF NOT EXISTS "+        <> placedTable+        <> " (\n"+        <> "  model_id TEXT PRIMARY KEY,\n"+        <> "  amount BIGINT NOT NULL,\n"+        <> "  last_seen BIGINT NOT NULL\n"+        <> ")"++upsertPlacedStmt :: Statement (Text, Int64, Int64) ()+upsertPlacedStmt =+  preparable+    ( "INSERT INTO "+        <> placedTable+        <> " (model_id, amount, last_seen)\n"+        <> "VALUES ($1, $2, $3)\n"+        <> "ON CONFLICT (model_id) DO UPDATE\n"+        <> "  SET amount = EXCLUDED.amount, last_seen = EXCLUDED.last_seen"+    )+    ( contrazip3+        (E.param (E.nonNullable E.text))+        (E.param (E.nonNullable E.int8))+        (E.param (E.nonNullable E.int8))+    )+    D.noResult++selectPlacedStmt :: Statement Text Int+selectPlacedStmt =+  preparable+    ("SELECT COALESCE((SELECT amount FROM " <> placedTable <> " WHERE model_id = $1), 0)")+    (E.param (E.nonNullable E.text))+    (D.singleRow (Prelude.fromIntegral <$> D.column (D.nonNullable D.int8)))++-- Count matching base tables in a given schema; proves table placement.+pgTableCountStmt :: Statement (Text, Text) Int+pgTableCountStmt =+  preparable+    "SELECT count(*)::int FROM pg_tables WHERE schemaname = $1 AND tablename = $2"+    ( contrazip2+        (E.param (E.nonNullable E.text))+        (E.param (E.nonNullable E.text))+    )+    (D.singleRow (Prelude.fromIntegral <$> D.column (D.nonNullable D.int4)))++initializeProjectionDedupCounterTable :: Tx.Transaction ()+initializeProjectionDedupCounterTable =+  Tx.sql+    """+    CREATE TABLE IF NOT EXISTS projection_dedup_counter (+      id BOOLEAN PRIMARY KEY DEFAULT TRUE,+      amount BIGINT NOT NULL+    );++    INSERT INTO projection_dedup_counter (id, amount)+    VALUES (TRUE, 0)+    ON CONFLICT (id) DO NOTHING;+    """++upsertCounterReadModelStmt :: Statement (Text, Int64, Int64, Maybe UUID, Maybe Text) ()+upsertCounterReadModelStmt =+  preparable+    """+    INSERT INTO counter_read_model (model_id, amount, last_seen, source_event_id, actor)+    VALUES ($1, $2, $3, $4, $5)+    ON CONFLICT (source_event_id) DO NOTHING+    """+    ( contrazip5+        (E.param (E.nonNullable E.text))+        (E.param (E.nonNullable E.int8))+        (E.param (E.nonNullable E.int8))+        (E.param (E.nullable E.uuid))+        (E.param (E.nullable E.text))+    )+    D.noResult++incrementProjectionDedupCounterStmt :: Statement () ()+incrementProjectionDedupCounterStmt =+  preparable+    """+    UPDATE projection_dedup_counter+    SET amount = amount + 1+    WHERE id = TRUE+    """+    E.noParams+    D.noResult++selectProjectionDedupCounterStmt :: Statement () Int+selectProjectionDedupCounterStmt =+  preparable+    """+    SELECT amount+    FROM projection_dedup_counter+    WHERE id = TRUE+    """+    E.noParams+    (D.singleRow (Prelude.fromIntegral <$> D.column (D.nonNullable D.int8)))++projectionDedupCountStmt :: Statement Text Int64+projectionDedupCountStmt =+  preparable+    """+    SELECT count(*)+    FROM keiro.keiro_projection_dedup+    WHERE projection_name = $1+    """+    (E.param (E.nonNullable E.text))+    (D.singleRow (D.column (D.nonNullable D.int8)))++selectCounterMetaStmt :: Statement Text (Int64, Maybe Text, Maybe UUID)+selectCounterMetaStmt =+  preparable+    """+    SELECT amount, actor, source_event_id+    FROM counter_read_model+    WHERE model_id = $1+    """+    (E.param (E.nonNullable E.text))+    ( D.singleRow+        ( (,,)+            <$> D.column (D.nonNullable D.int8)+            <*> D.column (D.nullable D.text)+            <*> D.column (D.nullable D.uuid)+        )+    )++selectCounterReadModelStmt :: Statement Text Int+selectCounterReadModelStmt =+  preparable+    """+    SELECT COALESCE((SELECT amount FROM counter_read_model WHERE model_id = $1), 0)+    """+    (E.param (E.nonNullable E.text))+    (D.singleRow (Prelude.fromIntegral <$> D.column (D.nonNullable D.int8)))++upsertSubscriptionCursorStmt :: Statement (Text, Int64) ()+upsertSubscriptionCursorStmt =+  preparable+    """+    INSERT INTO subscriptions (subscription_name, stream_name, last_seen)+    VALUES ($1, '$all', $2)+    ON CONFLICT (subscription_name, consumer_group_member) DO UPDATE+      SET last_seen = EXCLUDED.last_seen,+          updated_at = now()+    """+    ( contrazip2+        (E.param (E.nonNullable E.text))+        (E.param (E.nonNullable E.int8))+    )+    D.noResult++upsertSubscriptionCursorMemberStmt :: Statement (Text, Int32, Int64) ()+upsertSubscriptionCursorMemberStmt =+  preparable+    """+    INSERT INTO subscriptions (subscription_name, stream_name, consumer_group_member, consumer_group_size, last_seen)+    VALUES ($1, '$all', $2, 2, $3)+    ON CONFLICT (subscription_name, consumer_group_member) DO UPDATE+      SET last_seen = EXCLUDED.last_seen,+          updated_at = now()+    """+    ( contrazip3+        (E.param (E.nonNullable E.text))+        (E.param (E.nonNullable E.int4))+        (E.param (E.nonNullable E.int8))+    )+    D.noResult++updateReadModelVersionStmt :: Statement (Text, Int64) ()+updateReadModelVersionStmt =+  preparable+    """+    UPDATE keiro.keiro_read_models+    SET version = $2+    WHERE name = $1+    """+    ( contrazip2+        (E.param (E.nonNullable E.text))+        (E.param (E.nonNullable E.int8))+    )+    D.noResult++updateReadModelStatusStmt :: Statement (Text, Text) ()+updateReadModelStatusStmt =+  preparable+    """+    UPDATE keiro.keiro_read_models+    SET status = $2+    WHERE name = $1+    """+    ( contrazip2+        (E.param (E.nonNullable E.text))+        (E.param (E.nonNullable E.text))+    )+    D.noResult++readModelXminStmt :: Statement Text Text+readModelXminStmt =+  preparable+    """+    SELECT xmin::text+    FROM keiro.keiro_read_models+    WHERE name = $1+    """+    (E.param (E.nonNullable E.text))+    (D.singleRow (D.column (D.nonNullable D.text)))++globalPositionToInt :: GlobalPosition -> Int64+globalPositionToInt (GlobalPosition value) = value++eventIdToUuid :: EventId -> UUID+eventIdToUuid (EventId value) = value++metadataActor :: RecordedEvent -> Maybe Text+metadataActor recorded = do+  Aeson.Object o <- recorded ^. #metadata+  Aeson.String s <- KeyMap.lookup "actor" o+  pure s++-- Router test fixtures: an effectful, data-dependent fan-out whose target set+-- is stored in a read-model table (router_targets) rather than computed purely.++newtype RouteGroup = RouteGroup Text+  deriving stock (Generic, Eq, Show)++-- | Maps a routing group to the list of target counter stream identifiers seeded+-- for it. The query is genuinely effectful: 'demoRouter' calls it via 'runQuery'.+routerTargetsReadModel :: ReadModel Text [Text]+routerTargetsReadModel =+  ReadModel+    { name = "router-targets-read-model",+      tableName = "router_targets",+      schema = "kiroku",+      subscriptionName = "router-targets-sub",+      version = 1,+      shapeHash = "router-targets-v1",+      defaultConsistency = Eventual,+      strongScope = EntireLog,+      query = \groupId -> Tx.statement groupId selectRouterTargetsStmt+    }++demoRouter ::+  (IOE :> es, Store :> es) =>+  Router+    RouteGroup+    (HsPred '[] CounterCommand)+    '[]+    CounterState+    CounterCommand+    CounterEvent+    es+demoRouter =+  Router+    { name = "demo-router",+      key = \(RouteGroup g) -> g,+      resolve = \(RouteGroup g) -> do+        result <- runQuery Nothing routerTargetsReadModel g+        pure $ case result of+          Right targetIds ->+            [ PMCommand {target = stream targetId, command = Add 1}+            | targetId <- targetIds+            ]+          Left _ -> [],+      targetEventStream = counterEventStream,+      targetProjections = const []+    }++unstableRouter ::+  (IOE :> es) =>+  IORef Int ->+  (Int -> [Text]) ->+  Router+    RouteGroup+    (HsPred '[] CounterCommand)+    '[]+    CounterState+    CounterCommand+    CounterEvent+    es+unstableRouter attemptsRef targetsFor =+  Router+    { name = "unstable-router",+      key = \(RouteGroup g) -> g,+      resolve = \_ -> do+        attempt <- liftIO (atomicModifyIORef' attemptsRef (\n -> (n + 1, n)))+        pure+          [ PMCommand {target = stream targetId, command = Add 1}+          | targetId <- targetsFor attempt+          ],+      targetEventStream = counterEventStream,+      targetProjections = const []+    }++isAppended :: PMCommandResult target -> Bool+isAppended = \case+  PMCommandAppended {} -> True+  _ -> False++isDuplicate :: PMCommandResult target -> Bool+isDuplicate = \case+  PMCommandDuplicate {} -> True+  _ -> False++initializeRouterTargetsTable :: Tx.Transaction ()+initializeRouterTargetsTable =+  Tx.sql+    """+    CREATE TABLE IF NOT EXISTS router_targets (+      group_id TEXT NOT NULL,+      target_id TEXT NOT NULL+    )+    """++insertRouterTargetStmt :: Statement (Text, Text) ()+insertRouterTargetStmt =+  preparable+    """+    INSERT INTO router_targets (group_id, target_id)+    VALUES ($1, $2)+    """+    ( contrazip2+        (E.param (E.nonNullable E.text))+        (E.param (E.nonNullable E.text))+    )+    D.noResult++selectRouterTargetsStmt :: Statement Text [Text]+selectRouterTargetsStmt =+  preparable+    """+    SELECT target_id+    FROM router_targets+    WHERE group_id = $1+    ORDER BY target_id+    """+    (E.param (E.nonNullable E.text))+    (D.rowList (D.column (D.nonNullable D.text)))++-- Router worker fixtures: an in-memory Shibuya adapter that records every+-- finalized AckDecision, plus a router whose dispatch always fails.++inMemoryAdapter ::+  (IOE :> es) =>+  IORef [AckDecision] ->+  [msg] ->+  Adapter es msg+inMemoryAdapter decisionsRef messages =+  Adapter+    { adapterName = "router-test-adapter",+      source = Streamly.fromList (fmap ingest messages),+      shutdown = pure ()+    }+  where+    ingest message =+      Ingested+        { envelope = routerTestEnvelope message,+          ack = AckHandle (\decision -> liftIO (modifyIORef' decisionsRef (<> [decision]))),+          lease = Nothing+        }++routerTestEnvelope :: msg -> Envelope msg+routerTestEnvelope message =+  Envelope+    { messageId = "router-test-message",+      cursor = Nothing,+      partition = Nothing,+      enqueuedAt = Nothing,+      traceContext = Nothing,+      headers = Nothing,+      attempt = Nothing,+      attributes = mempty,+      payload = message+    }++-- | A target aggregate with no outgoing edges: every command is rejected+-- (CommandRejected), so a dispatch through it surfaces as PMCommandFailed,+-- driving the worker's AckHalt branch.+rejectingEventStreamDef :: CounterEventStream+rejectingEventStreamDef =+  counterEventStreamDef & #transducer .~ rejectingTransducer++rejectingEventStream :: ValidatedCounterEventStream+rejectingEventStream = mkEventStreamOrThrow "rejecting-counter" rejectingEventStreamDef++-- | Accept every Add command except amount 9, which exercises a worker that+-- dead-letters one rejected dispatch and then successfully processes the next.+rejectNineEventStream :: ValidatedCounterEventStream+rejectNineEventStream = mkEventStreamOrThrow "reject-nine-counter" rejectNineEventStreamDef++rejectNineEventStreamDef :: CounterEventStream+rejectNineEventStreamDef =+  counterEventStreamDef & #transducer .~ rejectNineTransducer++rejectNineTransducer :: SymTransducer (HsPred '[] CounterCommand) '[] CounterState CounterCommand CounterEvent+rejectNineTransducer =+  SymTransducer+    { edgesOut = \case+        Counting ->+          [ Edge+              { guard =+                  PAnd+                    (matchInCtor addCtor)+                    (PNot (inpCtor addCtor #amount .== Keiki.lit 9)),+                update = UKeep,+                output = [pack addCtor counterAddedCtor (inpCtor addCtor #amount *: oNil)],+                target = Counting,+                mode = Keiki.Live+              }+          ],+      initial = Counting,+      initialRegs = RNil,+      isFinal = \_ -> False+    }++rejectingTransducer :: SymTransducer (HsPred '[] CounterCommand) '[] CounterState CounterCommand CounterEvent+rejectingTransducer =+  SymTransducer+    { edgesOut = \case+        Counting -> [],+      initial = Counting,+      initialRegs = RNil,+      isFinal = \_ -> False+    }++failingRouter ::+  Router+    RouteGroup+    (HsPred '[] CounterCommand)+    '[]+    CounterState+    CounterCommand+    CounterEvent+    es+failingRouter =+  Router+    { name = "failing-router",+      key = \(RouteGroup g) -> g,+      resolve = \_ -> pure [PMCommand {target = stream "failing-target", command = Add 1}],+      targetEventStream = rejectingEventStream,+      targetProjections = const []+    }++-- Flatten exported counter/gauge points to (instrument name, value).+flattenScalarPoints :: [ResourceMetricsExport] -> [(Text, NumberValue)]+flattenScalarPoints rmes =+  [ (name, val)+  | rme <- rmes,+    scope <- Vector.toList (resourceMetricsScopes rme),+    export <- Vector.toList (scopeMetricsExports scope),+    (name, val) <- pointsOf export+  ]+  where+    pointsOf (MetricExportSum n _ _ _ _ _ _ pts) =+      [(n, sumDataPointValue p) | p <- Vector.toList pts]+    pointsOf (MetricExportGauge n _ _ _ _ pts) =+      [(n, gaugeDataPointValue p) | p <- Vector.toList pts]+    pointsOf _ = []++-- Flatten exported histogram points to (instrument name, count, sum).+flattenHistogramPoints :: [ResourceMetricsExport] -> [(Text, Word64, Double)]+flattenHistogramPoints rmes =+  [ (n, histogramDataPointCount p, histogramDataPointSum p)+  | rme <- rmes,+    scope <- Vector.toList (resourceMetricsScopes rme),+    export <- Vector.toList (scopeMetricsExports scope),+    MetricExportHistogram n _ _ _ _ pts <- [export],+    p <- Vector.toList pts+  ]++-- ===========================================================================+-- EP-51 sharded-subscription test helpers+-- ===========================================================================++-- A test sink the sharded handlers write to: one row per processed event,+-- idempotent on event_id (an at-least-once handler may redeliver during a+-- rebalance). worker_tag identifies which worker process handled it; stream_id+-- is the originating stream (the partition key kiroku hashes on).+createShardSinkSql :: ByteString+createShardSinkSql =+  "CREATE TABLE IF NOT EXISTS shard_sink \+  \(event_id uuid PRIMARY KEY, worker_tag int NOT NULL, stream_id bigint NOT NULL)"++-- Seed @nStreams@ category-@orders@ streams with @perStream@ events each+-- (upsert append, so it is safe to call twice in one test). Returns the total+-- number of events appended.+seedOrders :: Store.KirokuStore -> Int -> Int -> IO Int+seedOrders store nStreams perStream = do+  for_ [0 .. nStreams - 1] $ \i -> do+    let sname = StreamName ("orders-" <> Text.pack (show i))+        evs =+          [ EventData+              { eventId = Nothing,+                eventType = EventType "OrderPlaced",+                payload = object ["n" Aeson..= (j :: Int)],+                metadata = Nothing,+                causationId = Nothing,+                correlationId = Nothing+              }+          | j <- [0 .. perStream - 1]+          ]+    Right _ <- Store.runStoreIO store $ Store.appendToStream sname AnyVersion evs+    pure ()+  pure (nStreams * perStream)++-- A handler for worker @tag@: idempotently record (event_id, tag, stream_id).+sinkHandler :: Store.KirokuStore -> Int32 -> RecordedEvent -> IO ()+sinkHandler store tag ev =+  void $+    Store.runStoreIO store $+      Store.runTransaction $+        Tx.statement (eventUuid (ev ^. #eventId), tag, streamIdInt (ev ^. #originalStreamId)) insertShardSinkStmt+  where+    eventUuid (EventId u) = u+    streamIdInt (StreamId s) = s++insertShardSinkStmt :: Statement (UUID, Int32, Int64) ()+insertShardSinkStmt =+  preparable+    "INSERT INTO shard_sink (event_id, worker_tag, stream_id) VALUES ($1, $2, $3) ON CONFLICT (event_id) DO NOTHING"+    ( contrazip3+        (E.param (E.nonNullable E.uuid))+        (E.param (E.nonNullable E.int4))+        (E.param (E.nonNullable E.int8))+    )+    D.noResult++shardSinkCount :: Store.KirokuStore -> IO Int+shardSinkCount store =+  either (const 0) id+    <$> Store.runStoreIO store (Store.runTransaction (Tx.statement () countShardSinkStmt))++countShardSinkStmt :: Statement () Int+countShardSinkStmt =+  preparable+    "SELECT count(*) FROM shard_sink"+    E.noParams+    (D.singleRow (fromIntegral <$> D.column (D.nonNullable D.int8)))++shardDeadLetterDetails :: Store.KirokuStore -> Text -> IO (Int, Maybe Text, Maybe Int)+shardDeadLetterDetails store subscription =+  either (const (0, Nothing, Nothing)) id+    <$> Store.runStoreIO store (Store.runTransaction (Tx.statement subscription shardDeadLetterDetailsStmt))++shardDeadLetterDetailsStmt :: Statement Text (Int, Maybe Text, Maybe Int)+shardDeadLetterDetailsStmt =+  preparable+    "SELECT count(*)::bigint, max(reason_summary), max(attempt_count) \+    \FROM kiroku.dead_letters \+    \WHERE subscription_name = $1 AND consumer_group_member = 0"+    (E.param (E.nonNullable E.text))+    ( D.singleRow $+        (,,)+          <$> (fromIntegral <$> D.column (D.nonNullable D.int8))+          <*> D.column (D.nullable D.text)+          <*> (fmap fromIntegral <$> D.column (D.nullable D.int4))+    )++-- The largest number of distinct workers that processed any single stream. 1+-- means perfectly disjoint ownership (no stream split across workers).+maxWorkersPerStream :: Store.KirokuStore -> IO Int+maxWorkersPerStream store =+  either (const 0) id+    <$> Store.runStoreIO store (Store.runTransaction (Tx.statement () maxWorkersPerStreamStmt))++maxWorkersPerStreamStmt :: Statement () Int+maxWorkersPerStreamStmt =+  preparable+    "SELECT COALESCE(MAX(c), 0) FROM \+    \(SELECT count(DISTINCT worker_tag) AS c FROM shard_sink GROUP BY stream_id) s"+    E.noParams+    (D.singleRow (fromIntegral <$> D.column (D.nonNullable D.int8)))++-- How many distinct workers processed at least one event (proves the work+-- spread across the pool rather than monopolised by one worker).+distinctWorkers :: Store.KirokuStore -> IO Int+distinctWorkers store =+  either (const 0) id+    <$> Store.runStoreIO store (Store.runTransaction (Tx.statement () distinctWorkersStmt))++distinctWorkersStmt :: Statement () Int+distinctWorkersStmt =+  preparable+    "SELECT count(DISTINCT worker_tag) FROM shard_sink"+    E.noParams+    (D.singleRow (fromIntegral <$> D.column (D.nonNullable D.int8)))++-- Poll the sink count until it reaches @target@ or the timeout elapses.+waitUntilSinkCount :: Store.KirokuStore -> Int -> Int -> IO Bool+waitUntilSinkCount store target timeoutMicros = go (max 1 (timeoutMicros `div` step))+  where+    step = 100_000+    go :: Int -> IO Bool+    go 0 = (>= target) <$> shardSinkCount store+    go n = do+      c <- shardSinkCount store+      if c >= target+        then pure True+        else threadDelay step >> go (n - 1)++-- Poll until at least @target@ shard rows have a live owner. Tests use this to+-- join a second worker at a precise point in the one-bucket-per-pass ramp-up.+waitUntilOwnedShardCount :: Store.KirokuStore -> SubscriptionName -> Int -> Int -> IO Bool+waitUntilOwnedShardCount store sub target timeoutMicros = go (max 1 (timeoutMicros `div` step))+  where+    step = 50_000+    go 0 = hasTarget+    go n = do+      reached <- hasTarget+      if reached then pure True else threadDelay step >> go (n - 1)+    hasTarget = do+      rows <- either (const []) id <$> Store.runStoreIO store (Store.runTransaction (listShardOwnership sub))+      pure (length [() | (_, Just _, _) <- rows] >= target)++-- Poll the lease table until cooperative ownership has converged: every bucket+-- owned, at least @minWorkers@ distinct owners, and no owner holding more than+-- its fair share. This is the "balanced on the empty category" gate the+-- failover test waits on before seeding, so the drain runs under stable+-- membership.+waitShardsBalanced :: Store.KirokuStore -> SubscriptionName -> Int -> Int -> Int -> IO Bool+waitShardsBalanced store sub n minWorkers timeoutMicros = go (max 1 (timeoutMicros `div` step))+  where+    step = 200_000+    go :: Int -> IO Bool+    go 0 = isBalanced+    go k = do+      ok <- isBalanced+      if ok then pure True else threadDelay step >> go (k - 1)+    isBalanced :: IO Bool+    isBalanced = do+      rows <- either (const []) id <$> Store.runStoreIO store (Store.runTransaction (listShardOwnership sub))+      let owners = [w | (_, Just w, _) <- rows]+          distinct = length (nubOrd owners)+          perOwner = [length g | g <- groupByOwner owners]+          fairShare = (n + max 1 distinct - 1) `div` max 1 distinct+      pure (length rows == n && length owners == n && distinct >= minWorkers && all (<= fairShare) perOwner)+    groupByOwner ws = [filter (== w) ws | w <- nubOrd ws]+    nubOrd = Set.toList . Set.fromList++waitShardsUnowned :: Store.KirokuStore -> SubscriptionName -> Int -> Int -> IO Bool+waitShardsUnowned store sub n timeoutMicros = go (max 1 (timeoutMicros `div` step))+  where+    step = 100_000+    go 0 = isUnowned+    go k = do+      ok <- isUnowned+      if ok then pure True else threadDelay step >> go (k - 1)+    isUnowned = do+      rows <- either (const []) id <$> Store.runStoreIO store (Store.runTransaction (listShardOwnership sub))+      pure (length rows == n && all (\(_, owner, _) -> isNothing owner) rows)++workflowOwnedRowCounts :: (Store :> es) => Text -> Text -> Eff es (Int64, Int64, Int64, Int64, Int64, Int64)+workflowOwnedRowCounts name wid =+  Store.runTransaction (Tx.statement (wid, name) workflowOwnedRowCountsStmt)++workflowOwnedChildCount :: (Store :> es) => Text -> Text -> Eff es Int64+workflowOwnedChildCount name wid =+  Store.runTransaction (Tx.statement (wid, name, wid, name) workflowOwnedChildCountStmt)++workflowWakeAfter :: (Store :> es) => WorkflowName -> WorkflowId -> Eff es (Maybe UTCTime)+workflowWakeAfter (WorkflowName name) (WorkflowId wid) =+  Store.runTransaction (Tx.statement (wid, name) workflowWakeAfterStmt)++insertGcTimerStmt :: Statement (UUID, Text, Text, UTCTime, Value, Text) ()+insertGcTimerStmt =+  preparable+    """+    INSERT INTO keiro.keiro_timers+      (timer_id, process_manager_name, correlation_id, fire_at, payload, status)+    VALUES ($1, $2, $3, $4, $5, $6)+    """+    ( contrazip6+        (E.param (E.nonNullable E.uuid))+        (E.param (E.nonNullable E.text))+        (E.param (E.nonNullable E.text))+        (E.param (E.nonNullable E.timestamptz))+        (E.param (E.nonNullable E.jsonb))+        (E.param (E.nonNullable E.text))+    )+    D.noResult++deleteGcStepsStmt :: Statement (Text, Text) ()+deleteGcStepsStmt =+  preparable+    """+    DELETE FROM keiro.keiro_workflow_steps+    WHERE workflow_id = $1 AND workflow_name = $2+    """+    ( contrazip2+        (E.param (E.nonNullable E.text))+        (E.param (E.nonNullable E.text))+    )+    D.noResult++deleteWorkflowInstanceStmt :: Statement (Text, Text) ()+deleteWorkflowInstanceStmt =+  preparable+    """+    DELETE FROM keiro.keiro_workflows+    WHERE workflow_id = $1 AND workflow_name = $2+    """+    ( contrazip2+        (E.param (E.nonNullable E.text))+        (E.param (E.nonNullable E.text))+    )+    D.noResult++workflowWakeAfterStmt :: Statement (Text, Text) (Maybe UTCTime)+workflowWakeAfterStmt =+  preparable+    """+    SELECT wake_after+    FROM keiro.keiro_workflows+    WHERE workflow_id = $1 AND workflow_name = $2+    """+    ( contrazip2+        (E.param (E.nonNullable E.text))+        (E.param (E.nonNullable E.text))+    )+    (maybe Nothing id <$> D.rowMaybe (D.column (D.nullable D.timestamptz)))++workflowOwnedRowCountsStmt :: Statement (Text, Text) (Int64, Int64, Int64, Int64, Int64, Int64)+workflowOwnedRowCountsStmt =+  preparable+    """+    SELECT+      (SELECT count(*) FROM keiro.keiro_workflows WHERE workflow_id = $1 AND workflow_name = $2),+      (SELECT count(*) FROM keiro.keiro_workflow_steps WHERE workflow_id = $1 AND workflow_name = $2),+      (SELECT count(*) FROM keiro.keiro_awakeables WHERE owner_workflow_id = $1 AND owner_workflow_name = $2),+      (SELECT count(*) FROM keiro.keiro_workflow_children+        WHERE (parent_id = $1 AND parent_name = $2) OR (child_id = $1 AND child_name = $2)),+      (SELECT count(*) FROM keiro.keiro_timers+        WHERE correlation_id = $1 AND process_manager_name = $2 AND payload->>'kind' = 'keiro.workflow.sleep'),+      (SELECT count(*)+         FROM keiro.keiro_snapshots s+         JOIN streams st ON st.stream_id = s.stream_id+        WHERE st.stream_name = 'wf:' || $2 || '-' || $1)+    """+    ( contrazip2+        (E.param (E.nonNullable E.text))+        (E.param (E.nonNullable E.text))+    )+    ( D.singleRow $+        (,,,,,)+          <$> D.column (D.nonNullable D.int8)+          <*> D.column (D.nonNullable D.int8)+          <*> D.column (D.nonNullable D.int8)+          <*> D.column (D.nonNullable D.int8)+          <*> D.column (D.nonNullable D.int8)+          <*> D.column (D.nonNullable D.int8)+    )++workflowOwnedChildCountStmt :: Statement (Text, Text, Text, Text) Int64+workflowOwnedChildCountStmt =+  preparable+    """+    SELECT count(*)+    FROM keiro.keiro_workflow_children+    WHERE (parent_id = $1 AND parent_name = $2)+       OR (child_id = $3 AND child_name = $4)+    """+    ( contrazip4+        (E.param (E.nonNullable E.text))+        (E.param (E.nonNullable E.text))+        (E.param (E.nonNullable E.text))+        (E.param (E.nonNullable E.text))+    )+    (D.singleRow (D.column (D.nonNullable D.int8)))