diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,225 @@ +# Changelog + +All notable changes to the `keiro` library are recorded here. The format follows +[Keep a Changelog](https://keepachangelog.com/), and the project aims to follow +the [Haskell Package Versioning Policy](https://pvp.haskell.org/). + +## [Unreleased] + +_No unreleased changes._ + +## 0.2.0.0 — 2026-07-13 + +### Breaking Changes + +- **Keiro's framework tables moved out of the `kiroku` schema into a dedicated + `keiro` PostgreSQL schema.** Every runtime query is now fully qualified + (`keiro.keiro_snapshots`, `keiro.keiro_timers`, `keiro.keiro_outbox`, …) and no + longer depends on `search_path`. Existing databases must run the + `keiro-migrations` bootstrap that creates the schema and relocates the tables; + application SQL reading bare `keiro_*` relations must be re-qualified. +- `runCommandWithSql`, `runCommandWithSqlEvents`, `runCommandWithProjections`, + and the process-manager/router runners now require `KirokuStoreResource` so + transactional appends can apply Kiroku's configured `enrichEvent` hook. Acquire + the store with `withKirokuStore` and interpret `Store` with `runStoreResource`; + plain `runCommand` is unchanged. +- Read-model queries no longer auto-register missing registry rows. Applications + must call `registerReadModel` at projection startup; unknown models now return + `ReadModelUnregistered` without mutating the registry. +- `ReadModel` now requires a `strongScope :: StrongScope` field. Use `EntireLog` + for all-stream subscriptions or `CategoryHead category` for a category + subscription, so that unrelated traffic cannot hold `Strong` reads behind. +- `ReadModel` now also requires a `schema :: Text` field naming the PostgreSQL + schema its data table lives in. Keiro does not rewrite `query`; qualify the + application's SQL with `qualifiedTableName` or `Keiro.Connection.qualifyTable`. + The field is Haskell-level wiring only and is deliberately not persisted in the + `keiro.keiro_read_models` registry. +- `AsyncProjection` now requires `readModelName`, naming the registry row that + fences writes during a rebuild. +- `applyAsyncProjection` now returns `AsyncApplyOutcome` (`AsyncApplied`, + `AsyncDuplicate`, or `AsyncFenced`) and live workers must not checkpoint a + fenced event. Rebuild replayers use `applyAsyncProjectionUnfenced` between the + new atomic `startRebuild` and guarded `finishRebuild` helpers. +- Router deterministic command ids are now derived from the resolved target + stream name and same-stream occurrence rather than the target's list position + (`deterministicRouterCommandId`). A transition point-probe recognizes legacy + positional ids for stable resolver output and may be removed in a later + release. If both the deployment version and resolver output change between + attempts, a target command may be dispatched at most one extra time across that + one-time upgrade window. +- `runWorkflow`, `runWorkflowWith`, and the child-workflow runtime now require + `Error StoreError` in their effect rows, so post-commit workflow snapshot + failures can be caught without leaving the typed error channel. +- `HydrationReplayFailed` now carries a typed `HydrationReplayReason` alongside + the failing stream version. The reasons distinguish no inverting edge, ambiguous + inversion, queue mismatch, and a truncated multi-event chain. `CommandError` + also gains `CommandAmbiguous` (matched edge indices) and `HydrationGapDetected` + (expected and observed stream versions). +- A command matching multiple transitions is now reported as `CommandAmbiguous` + instead of `CommandRejected`. Process managers and routers halt on this + aggregate-definition bug, while generated timer dispositions route it through + their on-error arm rather than benign on-reject handling. +- `PMCommandResult.PMCommandFailed` now carries the target `StreamName` alongside + its `CommandError`, so worker policy can identify the failing target. +- `WorkerOptions` gains a `rejectedCommandPolicy :: RejectedCommandPolicy` field, + and `ShardedWorkerOptions` gains `handlerRetryDelay :: RetryDelay` and + `retryPolicy :: RetryPolicy`. Record construction must supply them; the + `defaultWorkerOptions` and `defaultShardedWorkerOptions` defaults are unchanged + in behavior except as noted below. +- The `hydration_replay_failed` telemetry class is replaced by four + reason-specific `error.type` values, and `command_ambiguous` is new. Dashboards + keyed on the old hydration class must be updated. +- Stream validation is stricter through the re-exported `keiro-core` contracts. + Keiki 0.2's head-recoverability, inversion-ambiguity, unguarded-input-read, and + state-changing-silent-edge checks now reject a stream at `mkEventStream`, and + `mkEventStreamWith` can no longer disable the head-recoverability or + state-changing-epsilon checks. Snapshot-enabled streams whose codec cannot + encode their initial state and registers are rejected at startup. `keiro` now + requires `keiki >=0.2`, `keiki-codec-json >=0.2`, and `kiroku-store >=0.3`. + +### New Features + +- New `Keiro.DeadLetter`, `Keiro.DeadLetter.Schema`, and `Keiro.DeadLetter.Replay` + modules. Process-manager and router workers can now park a rejected dispatch + instead of halting: `RejectedCommandPolicy` selects `RejectedHalt` (the + default), `RejectedDeadLetter` (persist a `DispatchDeadLetter` in + `keiro.keiro_dead_letters` and acknowledge), or `RejectedSkip` (acknowledge and + count). `recordDispatchDeadLetter` is idempotent under source-event redelivery, + and `listDispatchDeadLetters` reads one dispatcher's witnesses newest-first. + `replaySubscriptionDeadLetters` re-runs a caller-supplied handler over the rows + Kiroku parked in `kiroku.dead_letters`, reporting `ReplayedFresh`, + `ReplayedDuplicate`, `ReplayFailed`, or `ReplaySourceMissing` without deleting + or mutating the Kiroku-owned rows. +- New `Keiro.Connection` module for application read-model and projection tables: + `qualifyTable`, `quoteIdentifier`, `withProjectionSchema`, + `keiroConnectionSettings`, and the opt-in `ensureProjectionSchema`. The store + connection's `schema` stays `kiroku` because it drives the `LISTEN`/`NOTIFY` + channel; a projection schema is reached by qualification and/or + `extraSearchPath`. `ReadModel.qualifiedTableName` builds the model's + `"schema"."table"` reference. +- `Keiro.Subscription.Shard.Worker` gains an acknowledgement-aware surface: + `runShardedSubscriptionGroupAck` with `ShardAck`, `ShardDelivery`, and + `ShardEventHandler`, plus per-event retry and dead-letter dispositions. + `runShardedSubscriptionGroup` remains as the `RecordedEvent -> IO ()` + compatibility wrapper. +- Added `keiro.dispatch.deadlettered` and `keiro.subscription.deadlettered` + counters. `Keiro.Telemetry.kirokuEventBridge` installs on Kiroku's + `eventHandler` to observe `KirokuEventSubscriptionDeadLettered`, the terminal + retry-exhaustion signal, and delegates every event to the application's handler. +- Added `keiro.snapshot.encode.failures`, `keiro.snapshot.decode.failures`, + `keiro.snapshot.read.hits`, `keiro.snapshot.read.misses`, and + `keiro.snapshot.apply.divergence`. Snapshot lookup APIs (`lookupSnapshotSeed`, + `SnapshotLookup`, `SnapshotMissReason`, `encodeSnapshotStrict`, + `writeSnapshotEncoded`) now retain miss and decode reasons, while compatibility + wrappers preserve the previous `Maybe` surface. +- `commandErrorClass` exposes a stable error-class string for a `CommandError`. + `isRejectionClass`, `decideForFailures`, `DispatchFailure`, and + `confirmBenignDuplicate` are exported from `Keiro.ProcessManager` and + `Keiro.Router` so that custom workers can reuse the runtime's acknowledgement + classification. `ReadModel.categoryHeadPosition` reads the latest global + position originating in a Kiroku category. + +### Bug Fixes + +- Command hydration now detects stream-version gaps caused by Kiroku per-stream + truncation, and returns `HydrationGapDetected` unless a snapshot covers the + hidden prefix. +- Transactional command runners now apply Kiroku's configured `enrichEvent` hook + before event preparation, so persisted events and the `runCommandWithSqlEvents` + callback observe the same enriched metadata as plain `runCommand`. +- Router and process-manager duplicate-event rejections are now confirmed against + the intended target stream before being treated as benign. Unconfirmed + cross-stream or id-less collisions surface as command failures, causing workers + to halt instead of silently dropping a dispatch. +- Sharded subscription readers now acknowledge each event only after its handler + returns, using Kiroku's acknowledgement bridge. A shed or rebalanced bucket's + checkpoint can no longer cover an unprocessed event, and a synchronous handler + exception is retried in place under `retryPolicy` before Kiroku dead-letters the + event; asynchronous exceptions write no acknowledgement, and the event is + redelivered by the next owner. +- No-op commands now report `CommandResult.globalPosition = Nothing` instead of + exposing Kiroku's per-stream-read sentinel `GlobalPosition 0`. Appended commands + continue to report the real store-assigned position. + +### Other Changes + +- `RunCommandOptions.verifyReplayOnAppend` defaults on. Both command append paths + replay each just-committed batch from the pre-command state, count an + unreplayable batch through `keiro.snapshot.apply.divergence`, and attach a + bounded typed reason to `keiro.replay.divergence` without turning an + already-committed command into a reported failure. +- Aggregate snapshot encoding is forced before the store write. An `ErrorCall` + from a partial state encoder or an uninitialized register is swallowed after the + event append and counted, instead of escaping a successful command. +- Workflow snapshot writes after steps, completion, and continue-as-new rotation + are advisory: store failures are swallowed and counted after the journal append + commits. +- Corrected snapshot documentation: version non-regression applies within one + codec version and shape hash, while an incompatible codec can replace a newer + row to permit rollback. Upgrade notes cover the full-replay miss caused by + Keiki EP-78's stable shape hash. +- Documented previously implicit runtime contracts: the inbox deduplication window + closes when `garbageCollectCompleted` removes a completed row; outbox + `created_at` is transaction-start time, so `PerKeyHeadOfLine` and + `PerSourceStream` ordering is best-effort unless the caller serializes same-key + enqueues; the default timer worker has no attempt ceiling and requeues claims + left `Firing` for five minutes; and process-manager `correlate` joins across + streams must be order-insensitive. +- The shared PostgreSQL test fixture now provisions templates through the native + Kiroku/Keiro migration plan. Codd transition and remediation tests are retained + behind the manual `legacy-codd-tools` flag. +- Kiroku 0.3, Keiki 0.2, and pg-migrate 1.0 now resolve from Hackage; their + obsolete Git package overrides and the local Cabal overlay are no longer needed. + +## 0.1.0.0 — 2026-07-05 + +The initial Hackage release of `keiro`, an event-sourcing framework and workflow +engine that composes the kiroku event store, the keiki aggregate core, and the +shibuya worker substrate. + +### Breaking Changes + +- Command-boundary APIs require `ValidatedEventStream` instead of bare + `EventStream`: `runCommand`, `runCommandWithSql`, `runCommandWithSqlEvents`, + `runCommandWithProjections`, `Router.targetEventStream`, and + `ProcessManager.eventStream` / `targetEventStream`. Build stream definitions + with `mkEventStream` or `mkEventStreamOrThrow` before wiring them into runners. + This is source-level only; persisted events, snapshots, stream names, and wire + formats are unchanged. + +### New Features + +- Command-side write APIs with optimistic concurrency, idempotent event ids, + transactional SQL hooks, inline projections, command metadata, and OpenTelemetry + spans. +- Typed event codecs, schema-version metadata, ordered upcasters, advisory + snapshots, and replay-safe event-stream validation via `Keiro.EventStream.Validate`. +- Read models with consistency modes, rebuild lifecycle support, async projection + deduplication, and strong consistency checks. +- Process managers, routers, database-backed timers, shard workers, and worker + options for retry, halt, duplicate, and poison-message handling. +- Durable integration outbox and idempotent inbox support, including Kafka + adapters, trace propagation, retry accounting, dead-lettering, and maintenance + helpers. +- Durable workflow primitives: journaled named steps, sleep, await/signal, + child workflows, continue-as-new, patching, push wake signals, resume workers, + instance leasing, garbage collection, snapshots, and workflow telemetry. +- Metrics surfaces for command dispatch, projections, timers, outbox/inbox + workers, and workflow execution. + +### Bug Fixes + +- Hardened command retry, snapshot boundary handling, workflow crash windows, + process-manager/router ack finalization, timer requeueing, shard reader + recovery, async projection deduplication, and inbox/outbox recovery paths. +- Fixed duplicate-event classification, outbox publish grouping, no-op late + failure marks, and idempotent runtime release paths. + +### Other Changes + +- Re-exported the shared contracts from `keiro-core`, including codecs, streams, + event streams, validation, integration events, and snapshot policies. +- Added user guides, migration notes, Haddock coverage, API references, and + guide-backed examples for command-side usage, event evolution, snapshots, + read models, process managers, routers, integration events, and durable + workflows. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,99 @@ +# keiro — 経路 + +keiro is a Haskell library for event sourcing and workflow orchestration. It +combines an append-only event store, a pure functional state machine, and +subscription workers into one library-shaped runtime that an application imports +and runs against PostgreSQL. + +## The name + +**経路** (*keiro*) means **route**, **path**, or **course** in Japanese: the way +something travels from an origin to a destination. + +| Kanji | Reading | Meaning | +|---|---|---| +| 経 | *kei* | to pass through, to elapse, a way, a longitude | +| 路 | *ro* | a road, path, or way | + +The name is literal. keiro is about the paths events take through a system: + +- an event stream is the route an aggregate's history has taken; +- a subscription follows the route through the global event log; +- a projection routes events into queryable read models; +- a process manager routes source events into commands for another stream; +- a workflow is a durable route through state, timers, and external effects. + +The sibling project **keiki** (継起, "successive occurrence") names the +succession of events. **keiro** names the routes those events travel and the +routes downstream processes follow. + +## What it provides + +The current v1 library provides: + +- typed stream names through `Keiro.Stream`; +- event codecs, schema versions, event type validation, and upcasters through + `Keiro.Codec`; +- the author-facing `EventStream` contract in `Keiro.EventStream`; +- `runCommand` and `runCommandWithSql` in `Keiro.Command` for the canonical + load, streaming replay, decide, append-event-batch cycle with optimistic + concurrency; +- advisory snapshots in `Keiro.Snapshot`; +- read models, inline projections, async projection helpers, and rebuild + metadata in `Keiro.ReadModel` and `Keiro.Projection`; +- event-sourced process managers in `Keiro.ProcessManager`; +- durable timer storage and workers in `Keiro.Timer`. + +The stable contracts used by future Keiro packages live in the sibling +`keiro-core` package. The full `keiro` package depends on `keiro-core` and +re-exports those core modules, so existing imports such as `Keiro.Codec`, +`Keiro.EventStream`, `Keiro.Stream`, and `Keiro.Integration.Event` continue to +work for applications that depend on `keiro`. + +The top-level `Keiro` module re-exports the core stream, codec, event-stream, +command, and snapshot APIs. Read-model, projection, process-manager, and timer +modules are exposed directly so applications can import them explicitly. + +## Runtime stack + +keiro is not a server. The `keiro-core` package contains reusable contracts and +pure helpers; the `keiro` package adds the runtime that composes these +dependencies: + +- **kiroku** for the PostgreSQL-backed append-only event store; +- **keiki** for the pure `SymTransducer` state-machine core; +- **shibuya** for subscription and worker supervision; +- **hasql** and **effectful** for database access and effect handling; +- **Streamly** for streaming reads and worker loops. + +## Development + +From the repository root: + +```bash +cabal build all +cabal test all +cabal test jitsurei-test +just haskell-verify +``` + +The package metadata lives in `keiro/keiro.cabal`. The implementation plans and design +history live under `docs/masterplans/`, `docs/plans/`, and `docs/research/`. +User-facing documentation starts at `docs/user/README.md`. Long-form, +guide-backed examples start at `docs/guides/README.md` and use the sibling +`jitsurei` package as their executable source. + +## Status + +The v1 implementation MasterPlan is complete. The library currently includes +the package scaffold, public `EventStream` and codec contract, command cycle, +snapshots, read models and projections, process managers, and durable timer APIs. + +Remaining work is future-facing: the v2 deterministic durable-execution runtime, +exactly-once async projection checkpoint/user-SQL transactions once shibuya +exposes that boundary, and higher-level ergonomic facades over the low-level v1 +APIs. + +## License + +BSD-3-Clause. diff --git a/bench/Main.hs b/bench/Main.hs new file mode 100644 --- /dev/null +++ b/bench/Main.hs @@ -0,0 +1,305 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE OverloadedRecordDot #-} + +module Main ( + main, +) +where + +import Control.Concurrent (threadDelay) +import Data.ByteString qualified as BS +import Data.Text qualified as Text +import Data.Time (UTCTime (..), secondsToDiffTime) +import Data.Time.Calendar (Day (ModifiedJulianDay)) +import Data.UUID qualified as UUID +import Effectful (Eff, IOE, (:>)) +import Effectful.Error.Static (Error) +import Keiro.Inbox ( + InboxDedupePolicy (..), + InboxPersistence (..), + InboxResult (..), + KafkaDeliveryRef (..), + runInboxTransactionBatch, + runInboxTransactionWith, + ) +import Keiro.Integration.Event (IntegrationContentType (..), IntegrationEvent (..)) +import Keiro.Outbox ( + OutboxId (..), + OutboxRow, + PublishOutcome (..), + countOutboxBacklog, + defaultPublishOptions, + enqueueIntegrationEventTx, + publishClaimedOutbox, + ) +import Keiro.Prelude +import Keiro.Telemetry qualified as Telemetry +import Keiro.Test.Postgres (withFreshStore, withMigratedSuite) +import Kiroku.Store qualified as Store +import Kiroku.Store.Effect (Store) +import OpenTelemetry.MeterProvider (createMeterProvider, defaultSdkMeterProviderOptions) +import OpenTelemetry.Metric.Core (getMeter) +import OpenTelemetry.Resource (emptyMaterializedResources) +import Test.Tasty.Bench (Benchmark, bench, bgroup, defaultMain, nfIO) +import "hasql-transaction" Hasql.Transaction qualified as Tx + +workloadSize :: Int +workloadSize = 2000 + +seedChunkSize :: Int +seedChunkSize = 500 + +payloadSize :: Int +payloadSize = 1024 + +maxDrainPasses :: Int +maxDrainPasses = 2000 + +fixedOccurredAt :: UTCTime +fixedOccurredAt = UTCTime (ModifiedJulianDay 61000) (secondsToDiffTime 0) + +data BrokerModel = BrokerModel + { invocationMicros :: !Int + , perRecordMicros :: !Int + } + deriving stock (Eq, Show) + +data OutboxScenario = OutboxScenario + { scenarioName :: !Text + , brokerModel :: !BrokerModel + , messages :: ![(OutboxId, IntegrationEvent)] + } + +data InboxScenario = InboxScenario + { inboxScenarioName :: !Text + , inboxMetrics :: !(Maybe Telemetry.KeiroMetrics) + , inboxPersistence :: !InboxPersistence + , inboxBatchSize :: !(Maybe Int) + , inboxMessages :: ![(IntegrationEvent, KafkaDeliveryRef)] + } + +main :: IO () +main = + withMigratedSuite \fixture -> + withFreshStore fixture \store -> do + (provider, _env) <- + createMeterProvider + emptyMaterializedResources + defaultSdkMeterProviderOptions + meter <- getMeter provider Telemetry.keiroInstrumentationLibrary + metrics <- Telemetry.newKeiroMetrics meter + defaultMain (benchmarks store metrics) + +benchmarks :: Store.KirokuStore -> Telemetry.KeiroMetrics -> [Benchmark] +benchmarks store metrics = + [ bgroup + "outbox" + [ scenarioBench store hotKey + , scenarioBench store hotKeyNoLatency + , scenarioBench store multiKey + ] + , bgroup + "inbox" + [ inboxScenarioBench store (singleFull metrics) + , inboxScenarioBench store singleNoMetrics + , inboxScenarioBench store batch100 + , inboxScenarioBench store singleSlim + ] + ] + where + hotKey = + OutboxScenario + { scenarioName = "hot-key" + , brokerModel = BrokerModel{invocationMicros = 1000, perRecordMicros = 10} + , messages = scenarioMessages \_ -> Just "aggregate-hot" + } + hotKeyNoLatency = + OutboxScenario + { scenarioName = "hot-key-nolatency" + , brokerModel = BrokerModel{invocationMicros = 0, perRecordMicros = 0} + , messages = scenarioMessages \_ -> Just "aggregate-hot" + } + multiKey = + OutboxScenario + { scenarioName = "multi-key" + , brokerModel = BrokerModel{invocationMicros = 1000, perRecordMicros = 10} + , messages = scenarioMessages \i -> Just ("aggregate-" <> Text.pack (show (i `mod` 200))) + } + singleFull metrics' = + InboxScenario + { inboxScenarioName = "single-full" + , inboxMetrics = Just metrics' + , inboxPersistence = PersistFullEnvelope + , inboxBatchSize = Nothing + , inboxMessages = inboxScenarioMessages + } + singleNoMetrics = + InboxScenario + { inboxScenarioName = "single-nometrics" + , inboxMetrics = Nothing + , inboxPersistence = PersistFullEnvelope + , inboxBatchSize = Nothing + , inboxMessages = inboxScenarioMessages + } + batch100 = + InboxScenario + { inboxScenarioName = "batch-100" + , inboxMetrics = Nothing + , inboxPersistence = PersistFullEnvelope + , inboxBatchSize = Just 100 + , inboxMessages = inboxScenarioMessages + } + singleSlim = + InboxScenario + { inboxScenarioName = "single-slim" + , inboxMetrics = Nothing + , inboxPersistence = PersistDedupeOnly + , inboxBatchSize = Nothing + , inboxMessages = inboxScenarioMessages + } + +scenarioBench :: Store.KirokuStore -> OutboxScenario -> Benchmark +scenarioBench store scenario = + bench (Text.unpack scenario.scenarioName) $ + nfIO (runScenario store scenario) + +runScenario :: Store.KirokuStore -> OutboxScenario -> IO () +runScenario store scenario = do + runStoreChecked store do + Store.runTransaction (Tx.sql "TRUNCATE keiro_outbox") + seedOutbox store scenario.messages + runStoreChecked store (drainOutbox scenario.brokerModel 0) + +inboxScenarioBench :: Store.KirokuStore -> InboxScenario -> Benchmark +inboxScenarioBench store scenario = + bench (Text.unpack scenario.inboxScenarioName) $ + nfIO (runInboxScenario store scenario) + +runInboxScenario :: Store.KirokuStore -> InboxScenario -> IO () +runInboxScenario store scenario = do + runStoreChecked store do + Store.runTransaction (Tx.sql "TRUNCATE keiro_inbox") + runStoreChecked store $ + case scenario.inboxBatchSize of + Nothing -> + traverse_ + (processInboxDelivery scenario.inboxMetrics scenario.inboxPersistence) + scenario.inboxMessages + Just batchSize -> + traverse_ + (processInboxBatch scenario.inboxMetrics scenario.inboxPersistence) + (chunksOf batchSize scenario.inboxMessages) + +processInboxDelivery :: + (IOE :> es, Store :> es) => + Maybe Telemetry.KeiroMetrics -> + InboxPersistence -> + (IntegrationEvent, KafkaDeliveryRef) -> + Eff es () +processInboxDelivery mMetrics persistence (event, kafkaRef) = do + result <- runInboxTransactionWith mMetrics persistence PreferIntegrationMessageId event (Just kafkaRef) (\_ -> pure ()) + case result of + Right (InboxProcessed ()) -> pure () + other -> liftIO (fail ("unexpected inbox benchmark result: " <> show other)) + +processInboxBatch :: + (IOE :> es, Store :> es) => + Maybe Telemetry.KeiroMetrics -> + InboxPersistence -> + [(IntegrationEvent, KafkaDeliveryRef)] -> + Eff es () +processInboxBatch mMetrics persistence chunk = do + results <- + runInboxTransactionBatch + mMetrics + 3 + PreferIntegrationMessageId + persistence + [(event, Just kafkaRef) | (event, kafkaRef) <- chunk] + (\_ -> pure ()) + for_ results \case + Right (InboxProcessed ()) -> pure () + other -> liftIO (fail ("unexpected inbox batch benchmark result: " <> show other)) + +seedOutbox :: Store.KirokuStore -> [(OutboxId, IntegrationEvent)] -> IO () +seedOutbox store messages = + traverse_ seedChunk (chunksOf seedChunkSize messages) + where + seedChunk chunk = + runStoreChecked store $ + Store.runTransaction $ + traverse_ (uncurry enqueueIntegrationEventTx) chunk + +drainOutbox :: (IOE :> es, Store :> es) => BrokerModel -> Int -> Eff es () +drainOutbox broker passes = do + backlog <- countOutboxBacklog + if backlog == 0 + then pure () + else do + when (passes >= maxDrainPasses) $ + liftIO (fail ("outbox benchmark exceeded safety cap of " <> show maxDrainPasses <> " passes")) + void (publishClaimedOutbox (simulatedPublish broker) defaultPublishOptions Nothing) + drainOutbox broker (passes + 1) + +simulatedPublish :: (IOE :> es) => BrokerModel -> [OutboxRow] -> Eff es [(OutboxId, PublishOutcome)] +simulatedPublish broker rows = do + let totalMicros = broker.invocationMicros + broker.perRecordMicros * length rows + when (totalMicros > 0) $ + liftIO (threadDelay totalMicros) + pure [(row ^. #outboxId, PublishSucceeded) | row <- rows] + +scenarioMessages :: (Int -> Maybe Text) -> [(OutboxId, IntegrationEvent)] +scenarioMessages keyFor = + [ (OutboxId (UUID.fromWords64 0x018f0f1800007000 (0x8000000000000000 + fromIntegral i)), integrationEvent i (keyFor i)) + | i <- [1 .. workloadSize] + ] + +integrationEvent :: Int -> Maybe Text -> IntegrationEvent +integrationEvent i key = + IntegrationEvent + { messageId = "bench-msg-" <> Text.pack (show i) + , source = "bench.outbox" + , destination = "bench.outbox.events.v1" + , key + , eventType = "BenchEvent" + , schemaVersion = 1 + , contentType = ApplicationJson + , schemaReference = Nothing + , sourceEventId = Nothing + , sourceGlobalPosition = Nothing + , payloadBytes = BS.replicate payloadSize 65 + , occurredAt = fixedOccurredAt + , causationId = Nothing + , correlationId = Nothing + , traceContext = Nothing + , attributes = Nothing + } + +inboxScenarioMessages :: [(IntegrationEvent, KafkaDeliveryRef)] +inboxScenarioMessages = + [ ( integrationEvent i (Just ("inbox-key-" <> Text.pack (show i))) + & #messageId + .~ ("bench-inbox-msg-" <> Text.pack (show i)) + & #source + .~ "bench.inbox" + & #destination + .~ "bench.inbox.events.v1" + , KafkaDeliveryRef "bench.inbox.events.v1" 0 (fromIntegral i) + ) + | i <- [1 .. workloadSize] + ] + +chunksOf :: Int -> [a] -> [[a]] +chunksOf n xs + | n <= 0 = error "chunksOf: non-positive chunk size" + | otherwise = + case splitAt n xs of + ([], _) -> [] + (chunk, rest) -> chunk : chunksOf n rest + +runStoreChecked :: Store.KirokuStore -> Eff [Store, Error Store.StoreError, IOE] a -> IO a +runStoreChecked store action = do + result <- Store.runStoreIO store action + case result of + Left err -> fail (show err) + Right value -> pure value diff --git a/keiro.cabal b/keiro.cabal new file mode 100644 --- /dev/null +++ b/keiro.cabal @@ -0,0 +1,190 @@ +cabal-version: 3.0 +name: keiro +version: 0.2.0.0 +synopsis: Event sourcing framework and workflow engine +description: + A library that composes kiroku, keiki, and shibuya into an + event-sourcing and workflow-orchestration framework. + +license: BSD-3-Clause +author: Nadeem Bitar +maintainer: nadeem@gmail.com +copyright: 2026 Nadeem Bitar +category: Control +homepage: https://github.com/shinzui/keiro#readme +bug-reports: https://github.com/shinzui/keiro/issues +build-type: Simple +tested-with: GHC >=9.12 && <9.13 +extra-doc-files: + CHANGELOG.md + README.md + +source-repository head + type: git + location: https://github.com/shinzui/keiro.git + +common warnings + ghc-options: + -Wall -Wcompat -Widentities -Wincomplete-record-updates + -Wincomplete-uni-patterns -Wpartial-fields -Wredundant-constraints + +common shared + default-language: GHC2024 + default-extensions: + DeriveAnyClass + DuplicateRecordFields + MultilineStrings + OverloadedLabels + OverloadedStrings + PackageImports + +library + import: warnings, shared + exposed-modules: + Keiro + Keiro.Command + Keiro.Connection + Keiro.DeadLetter + Keiro.DeadLetter.Replay + Keiro.DeadLetter.Schema + Keiro.Inbox + Keiro.Inbox.Kafka + Keiro.Inbox.Schema + Keiro.Inbox.Types + Keiro.Outbox + Keiro.Outbox.Kafka + Keiro.Outbox.Schema + Keiro.Outbox.Types + Keiro.ProcessManager + Keiro.Projection + Keiro.ReadModel + Keiro.ReadModel.Rebuild + Keiro.ReadModel.Schema + Keiro.Router + Keiro.Snapshot + Keiro.Snapshot.Codec + Keiro.Snapshot.Schema + Keiro.Subscription.Shard + Keiro.Subscription.Shard.Schema + Keiro.Subscription.Shard.Worker + Keiro.Telemetry + Keiro.Timer + Keiro.Timer.Schema + Keiro.Timer.Types + Keiro.Wake + Keiro.Workflow + Keiro.Workflow.Awakeable + Keiro.Workflow.Awakeable.Schema + Keiro.Workflow.Child + Keiro.Workflow.Child.Schema + Keiro.Workflow.Gc + Keiro.Workflow.Instance + Keiro.Workflow.Resume + Keiro.Workflow.Schema + Keiro.Workflow.Sleep + Keiro.Workflow.Snapshot + Keiro.Workflow.Types + + reexported-modules: + keiro-core:Keiro.Codec, + keiro-core:Keiro.EventStream, + keiro-core:Keiro.EventStream.Validate, + keiro-core:Keiro.Integration.Event, + keiro-core:Keiro.Prelude, + keiro-core:Keiro.Snapshot.Policy, + keiro-core:Keiro.Stream + + hs-source-dirs: src + build-depends: + , aeson >=2.2 + , aeson-casing >=0.2 + , base >=4.21 && <5 + , bytestring >=0.11 + , containers >=0.6 + , contravariant-extras >=0.3 + , deepseq >=1.5 + , effectful >=2.6 + , effectful-core >=2.6 + , generic-lens >=2.2 + , hasql >=1.10 + , hasql-pool >=1.2 + , hasql-transaction >=1.1 + , hs-opentelemetry-api >=1.0 && <1.1 + , hs-opentelemetry-propagator-w3c >=1.0 && <1.1 + , hs-opentelemetry-semantic-conventions >=1.40 && <2 + , keiki >=0.2 && <0.3 + , keiki-codec-json >=0.2 && <0.3 + , keiro-core ^>=0.2.0.0 + , kiroku-store >=0.3 && <0.4 + , lens >=5.2 + , mmzk-typeid >=0.7 + , scientific >=0.3 + , shibuya-core >=0.8.0.1 && <0.9 + , stm >=2.5 + , streamly >=0.11 + , streamly-core >=0.3 + , text >=2.1 + , time >=1.12 + , unliftio-core >=0.2 + , uuid >=1.3 + , vector >=0.13 + +test-suite keiro-test + import: warnings, shared + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Main.hs + ghc-options: -threaded -rtsopts -with-rtsopts=-N + build-depends: + , aeson >=2.2 + , base >=4.21 && <5 + , bytestring >=0.11 + , containers >=0.6 + , contravariant-extras >=0.3 + , effectful >=2.6 + , effectful-core >=2.6 + , hasql >=1.10 + , hasql-pool >=1.2 + , hasql-transaction >=1.1 + , hs-opentelemetry-api >=1.0 && <1.1 + , hs-opentelemetry-exporter-in-memory >=1.0 && <1.1 + , hs-opentelemetry-propagator-w3c >=1.0 && <1.1 + , hs-opentelemetry-sdk >=1.0 && <1.1 + , hs-opentelemetry-semantic-conventions >=1.40 && <2 + , hspec >=2.11 + , keiki + , keiki-codec-json + , keiro + , keiro-test-support + , kiroku-store >=0.3 && <0.4 + , process >=1.6 + , shibuya-core >=0.8.0.1 && <0.9 + , stm >=2.5 + , streamly-core >=0.3 + , text >=2.1 + , time >=1.12 + , unliftio-core >=0.2 + , uuid >=1.3 + , vector >=0.13 + +benchmark keiro-bench + import: warnings, shared + type: exitcode-stdio-1.0 + hs-source-dirs: bench + main-is: Main.hs + ghc-options: -threaded -rtsopts -with-rtsopts=-N + build-depends: + , base >=4.21 && <5 + , bytestring >=0.11 + , effectful >=2.6 + , hasql-transaction >=1.1 + , hs-opentelemetry-api >=1.0 && <1.1 + , hs-opentelemetry-sdk >=1.0 && <1.1 + , keiro + , keiro-core ^>=0.2.0.0 + , keiro-test-support + , kiroku-store >=0.3 && <0.4 + , tasty-bench >=0.4 + , text >=2.1 + , time >=1.12 + , uuid >=1.3 diff --git a/src/Keiro.hs b/src/Keiro.hs new file mode 100644 --- /dev/null +++ b/src/Keiro.hs @@ -0,0 +1,57 @@ +{- | Umbrella entry point for the Keiro event-sourcing framework. + +Importing @Keiro@ brings the everyday command-side surface into scope in +one go: the command runner ("Keiro.Command"), event 'Codec's +("Keiro.Codec"), the 'EventStream' definition and its snapshot policy +("Keiro.EventStream"), the content-based 'Router' ("Keiro.Router"), +snapshot helpers ("Keiro.Snapshot"), and typed 'Stream' handles +("Keiro.Stream"). + +The more specialized subsystems are not re-exported here and are imported +directly when needed: read models ("Keiro.ReadModel"), projections +("Keiro.Projection"), process managers ("Keiro.ProcessManager"), the +integration in/outbox ("Keiro.Inbox", "Keiro.Outbox"), timers +("Keiro.Timer"), and telemetry ("Keiro.Telemetry"). + +Known limit: Keiro currently uses kiroku's PostgreSQL event store, whose append +path serializes all writers through the @$all@ stream row while assigning the +global event order. That makes the global position simple and deterministic, +but it is a throughput ceiling for very high write rates across many unrelated +streams. This production-readiness hardening pass documents the limit rather +than redesigning it; applications that outgrow the single-row global append +lock need a future event-store migration plan. +-} +module Keiro ( + -- * Library version + version, + + -- * Command side + module Keiro.Command, + module Keiro.Codec, + + -- * Stream definitions + EventStream (..), + Terminality (..), + SnapshotPolicy (..), + StateCodec (..), + module Keiro.EventStream.Validate, + module Keiro.Stream, + + -- * Routing and snapshots + module Keiro.Router, + module Keiro.Snapshot, +) +where + +import Keiro.Codec +import Keiro.Command +import Keiro.EventStream +import Keiro.EventStream.Validate +import Keiro.Prelude +import Keiro.Router +import Keiro.Snapshot +import Keiro.Stream + +-- | The Keiro library version, as a 'Text' for display and telemetry. +version :: Text +version = "0.1.0.0" diff --git a/src/Keiro/Command.hs b/src/Keiro/Command.hs new file mode 100644 --- /dev/null +++ b/src/Keiro/Command.hs @@ -0,0 +1,900 @@ +{- | The command side of the framework: hydrate an aggregate, transduce, append. + +Running a command against an 'EventStream' follows one pipeline: + +1. /Hydrate/ — replay the stream's stored events (optionally fast-forwarding + from a snapshot) through the keiki transducer to recover the current + @(state, registers)@ and stream version. +2. /Transduce/ — step the transducer with the command. A rejected transition + yields 'CommandRejected', while multiple matching transitions yield + 'CommandAmbiguous'; a transition that emits no events yields a no-op + 'CommandResult'. +3. /Append/ — encode the emitted events with the stream's 'Codec' and append + them at the expected version. An optimistic-concurrency conflict is + retried up to 'retryLimit' times by rehydrating and replaying; exhausting + the budget yields 'RetryExhausted'. + +Three runners expose this pipeline at increasing levels of integration: + +* 'runCommand' — append only. +* 'runCommandWithSql' — run an extra @afterAppend@ action in the /same/ + transaction as the append (e.g. update an inline read model). +* 'runCommandWithSqlEvents' — same, but the callback also receives the + emitted events paired with their 'RecordedEvent's. This is the primitive + the projection, process-manager, and router layers build on. + +The transactional runners apply Kiroku's configured @enrichEvent@ hook before +event preparation, exactly like 'runCommand'. They therefore require a +'KirokuStoreResource' in the effect stack; install it with @withKirokuStore@ +and interpret 'Store' with @runStoreResource@. + +Per-stream hydration honors Kiroku's stream-truncation marker. A retained +snapshot must cover every hidden event (snapshot version at least marker minus +one); otherwise hydration fails with 'HydrationGapDetected'. A marker above +the stream head can instead appear as an empty stream and repeated append +conflicts end in 'ConflictFixpoint'. Keiro never truncates streams itself. +Kiroku's @$all@ and category/subscription reads are unaffected by per-stream +truncation: the marker hides events from stream reads rather than deleting +them from the global log. + +Every successful append is replayed immediately from its pre-command state so +an unreplayable batch is witnessed at the moment it poisons the stream. The +post-commit witness is counted and attached to the command span without +changing the successful result. The same replay fold feeds transparent +snapshot writes when the stream's 'Keiro.EventStream.SnapshotPolicy' fires; +post-commit snapshot failures are likewise swallowed and counted. Every runner +accepts a tracer for optional OpenTelemetry spans. +-} +module Keiro.Command ( + -- * Results and errors + CommandResult (..), + CommandError (..), + HydrationReplayReason (..), + commandErrorClass, + + -- * Options + RunCommandOptions (..), + defaultRunCommandOptions, + + -- * Running commands + runCommand, + runCommandWithSql, + runCommandWithSqlEvents, +) +where + +import Control.Concurrent (threadDelay) +import Data.Functor (($>)) +import Data.Int (Int32) +import Data.Text qualified as Text +import Effectful (Eff, IOE, (:>)) +import Effectful.Error.Static (Error, tryError) +import GHC.Clock (getMonotonicTimeNSec) +import GHC.Stack (HasCallStack) +import Keiki.Core (BoolAlg, RegFile) +import Keiki.Core qualified as Keiki +import Keiro.Codec (Codec, CodecError, decodeRecorded, encodeForAppendWithMetadata) +import Keiro.EventStream (EventStream, Terminality (..)) +import Keiro.EventStream.Validate (ValidatedEventStream, unvalidated) +import Keiro.Prelude +import Keiro.Snapshot ( + SnapshotLookup (..), + SnapshotMissReason (..), + encodeSnapshotStrict, + lookupSnapshotSeed, + writeSnapshotEncoded, + ) +import Keiro.Snapshot.Policy (shouldSnapshotSpan) +import Keiro.Stream (Stream) +import Keiro.Telemetry ( + KeiroMetrics, + keiro_events_appended, + keiro_replay_divergence, + keiro_retry_attempt, + recordCommandConflicts, + recordCommandDuplicates, + recordCommandRetries, + recordSnapshotApplyDivergence, + recordSnapshotDecodeFailures, + recordSnapshotEncodeFailures, + recordSnapshotReadHits, + recordSnapshotReadMisses, + recordSnapshotWriteFailures, + withCommandSpan, + ) +import Kiroku.Store.Append (appendToStream) +import Kiroku.Store.Effect (Store) +import Kiroku.Store.Effect.Resource (KirokuStoreResource, getKirokuStore) +import Kiroku.Store.Error (StoreError (..)) +import Kiroku.Store.Read (readStreamForwardStream) +import Kiroku.Store.Transaction ( + PreparedEvent, + appendConflictToStoreError, + appendToStreamTx, + enrichEventsIO, + prepareEventsIO, + runTransaction, + ) +import Kiroku.Store.Types ( + AppendResult, + EventData, + EventId (..), + ExpectedVersion (..), + GlobalPosition (..), + RecordedEvent (..), + StreamName (..), + StreamVersion (..), + ) +import OpenTelemetry.Attributes.Key (unkey) +import OpenTelemetry.SemanticConventions (db_system_name, error_type) +import OpenTelemetry.Trace.Core (Span, SpanStatus (..), Tracer, addAttribute, setStatus) +import Streamly.Data.Fold qualified as Fold +import Streamly.Data.Stream qualified as Streamly +import "hasql-transaction" Hasql.Transaction qualified as Tx +import Prelude qualified + +{- | The outcome of a successfully handled command. + +Reports the target 'Stream', the stream version after the command, the global +log position only when this command appended and the store assigned a real +one, and how many events were appended. A no-op reports @0@ events and +@Nothing@ for its global position because per-stream reads cannot recover a +true global position. +-} +data CommandResult target = CommandResult + { target :: !(Stream target) + , streamVersion :: !StreamVersion + , globalPosition :: !(Maybe GlobalPosition) + -- ^ 'Just' only when this command appended; 'Nothing' for a no-op. + , eventsAppended :: !Int + } + deriving stock (Generic, Eq, Show) + +-- | Why a command did not complete. +data CommandError + = -- | A stored event could not be decoded while rehydrating the aggregate. + HydrationDecodeFailed !CodecError + | {- | Replay of the stored events through the transducer stalled. The + version identifies the failing stored event; for + 'HydrationTruncatedChain' it identifies the last stored event, after + which the expected multi-event chain remained incomplete. + -} + HydrationReplayFailed !StreamVersion !HydrationReplayReason + | {- | Hydration observed a non-contiguous stream version. Carries the + expected version followed by the observed version. The store writes + contiguous versions, so this indicates that stream truncation hid + events not covered by the hydration seed. Restore visibility with + @clearStreamTruncateBefore@ or provide a covering snapshot before + retrying the command. + -} + HydrationGapDetected !StreamVersion !StreamVersion + | -- | No transducer edge matched the command in the hydrated state. + CommandRejected + | {- | Two or more transducer edges matched the command in the hydrated + state. This is a deterministic aggregate-definition bug rather than a + business rejection; the list contains the zero-based matched edge + indices in declaration order. + -} + CommandAmbiguous ![Int] + | -- | An emitted event could not be encoded for append. + EncodeFailed !CodecError + | -- | The underlying store rejected the append. + StoreFailed !StoreError + | {- | Optimistic-concurrency retries were exhausted (carries the total + attempts made and the last store error). + -} + RetryExhausted !Int !StoreError + | {- | Retrying after a 'StreamAlreadyExists' conflict re-observed the same + stream version: the store says the stream exists but reading it shows no + progress. The typical cause is a soft-deleted stream, where reads return + nothing but appends still collide. Carries the observed version and the + conflict. + -} + ConflictFixpoint !StreamVersion !StoreError + deriving stock (Generic, Eq, Show) + +{- | Why replay of stored events stalled, projected from keiki's structured +failure types onto a monomorphic vocabulary suitable for 'CommandError'. +-} +data HydrationReplayReason + = -- | No edge's first output template could have produced the event. + HydrationNoInvertingEdge + | -- | More than one edge could have produced the event. + HydrationAmbiguousInversion + | -- | An event did not match the next expected event in a chain. + HydrationQueueMismatch + | -- | The stream ended in the middle of a multi-event chain. + HydrationTruncatedChain + deriving stock (Generic, Eq, Show) + +{- | Knobs controlling a single command invocation. + +* 'retryLimit' — how many times to rehydrate-and-replay after an + optimistic-concurrency conflict before giving up with 'RetryExhausted'. +* 'pageSize' — batch size when reading the stream during hydration. +* 'eventIds' — caller-supplied ids assigned to the emitted events in order; + the basis for deterministic, idempotent appends (see 'Keiro.Router' and + 'Keiro.ProcessManager'). +* 'beforeAppend' — a hook run immediately before each append attempt, + primarily a test seam for injecting concurrent writes. +* 'retryBackoffMicros' — base delay before the k-th OCC retry, capped at + 100 ms and jittered. Set to 0 to disable backoff. +* 'metrics' — optional metrics handle for command and snapshot counters. +* 'verifyReplayOnAppend' — replay every just-appended batch from the + pre-command state. Divergence is a post-commit advisory: it is counted and + attached to the command span, but the already-successful command still + succeeds. Snapshot-enabled streams always run the fold because snapshots + consume its result. +-} +data RunCommandOptions = RunCommandOptions + { retryLimit :: !Int + , pageSize :: !Int32 + , eventIds :: ![EventId] + , beforeAppend :: !(IO ()) + , retryBackoffMicros :: !Int + , metrics :: !(Maybe KeiroMetrics) + , verifyReplayOnAppend :: !Bool + , tracer :: !(Maybe Tracer) + {- ^ Optional OpenTelemetry tracer. When 'Just', the command runner + opens an 'Internal'-kind span around each invocation, named after + the resolved stream identifier and decorated with the messaging / + error semantic-conventions attributes audited in + 'docs/research/opentelemetry-semconv-audit.md'. When 'Nothing', + the runner emits no spans. + -} + , metadata :: !(Maybe Value) + {- ^ Optional JSON merged into every event's metadata for this command + invocation. Carries ambient context such as actor type, agent id, + and session id. The codec always adds a @schemaVersion@ key; the + keys here are merged on top (see 'Keiro.Codec.metadataFor'). When + 'Nothing', events carry only the schema-version marker, exactly as + before this field existed. + -} + } + deriving stock (Generic) + +{- | Sensible defaults: 3 retries, 256-event read pages, no caller-assigned +event ids, a no-op pre-append hook, 5ms retry backoff, no metrics, post-append +replay verification enabled, no tracer, and no extra metadata. +-} +defaultRunCommandOptions :: RunCommandOptions +defaultRunCommandOptions = + RunCommandOptions + { retryLimit = 3 + , pageSize = 256 + , eventIds = [] + , beforeAppend = pure () + , retryBackoffMicros = 5000 + , metrics = Nothing + , verifyReplayOnAppend = True + , tracer = Nothing + , metadata = Nothing + } + +data Hydrated rs s = Hydrated + { state :: !s + , registers :: !(RegFile rs) + , streamVersion :: !StreamVersion + } + deriving stock (Generic) + +data CommandPlan target rs s co + = CommandNoOp !(CommandResult target) + | CommandAppend !(Hydrated rs s) ![co] ![EventData] + deriving stock (Generic) + +hydrate :: + forall phi rs s ci co es. + (HasCallStack, IOE :> es, Store :> es, BoolAlg phi (RegFile rs, ci), Eq co) => + RunCommandOptions -> + EventStream phi rs s ci co -> + Stream (EventStream phi rs s ci co) -> + Eff es (Either CommandError (Hydrated rs s)) +hydrate options eventStream targetStream = + snapshotSeed >>= \case + Nothing -> hydrateFull options eventStream targetStream + Just seed -> do + replayed <- + hydrateSeeded + options + eventStream + targetStream + (seed ^. #state) + (seed ^. #registers) + (seed ^. #streamVersion) + case replayed of + Left _ -> hydrateFull options eventStream targetStream + Right hydrated -> pure (Right hydrated) + where + snapshotSeed = + case eventStream ^. #stateCodec of + Nothing -> pure Nothing + Just codec -> do + lookupSnapshotSeed ((eventStream ^. #resolveStreamName) targetStream) codec >>= \case + SnapshotHit seed -> do + recordSnapshotReadHits (options ^. #metrics) 1 + pure (Just seed) + SnapshotUnavailable reason -> do + recordSnapshotReadMisses (options ^. #metrics) 1 + case reason of + SnapshotDecodeFailed _ -> recordSnapshotDecodeFailures (options ^. #metrics) 1 + _ -> pure () + pure Nothing + +hydrateFull :: + forall phi rs s ci co es. + (HasCallStack, Store :> es, BoolAlg phi (RegFile rs, ci), Eq co) => + RunCommandOptions -> + EventStream phi rs s ci co -> + Stream (EventStream phi rs s ci co) -> + Eff es (Either CommandError (Hydrated rs s)) +hydrateFull options eventStream targetStream = + hydrateSeeded + options + eventStream + targetStream + (eventStream ^. #initialState) + (eventStream ^. #initialRegisters) + (StreamVersion 0) + +{- | Replay a stored stream from an arbitrary snapshot or initial-state seed. + +The store stream is grouped into bounded lists and each decoded prefix is +handed to keiki's 'Keiki.replayEvents'. Decoding stops at the first bad event in +a group, but the valid prefix is replayed first so an earlier replay failure +retains precedence over a later codec failure. +-} +hydrateSeeded :: + forall phi rs s ci co es. + (HasCallStack, Store :> es, BoolAlg phi (RegFile rs, ci), Eq co) => + RunCommandOptions -> + EventStream phi rs s ci co -> + Stream (EventStream phi rs s ci co) -> + s -> + RegFile rs -> + StreamVersion -> + Eff es (Either CommandError (Hydrated rs s)) +hydrateSeeded options eventStream targetStream seedState seedRegisters seedVersion = do + replayed <- + Streamly.fold + (Fold.foldlM' replayPage (pure (Right initialReplay))) + recordedPages + pure (finishReplay replayed) + where + readPageSize = Prelude.max 1 (options ^. #pageSize) + groupSize = Prelude.fromIntegral readPageSize + recordedPages = + Streamly.foldMany + (Fold.take groupSize Fold.toList) + (readStreamForwardStream resolvedName seedVersion readPageSize) + resolvedName = (eventStream ^. #resolveStreamName) targetStream + initialReplay = (Keiki.Settled seedState, seedRegisters, Nothing) + + replayPage :: + Either CommandError (Keiki.InFlight s co, RegFile rs, Maybe RecordedEvent) -> + [RecordedEvent] -> + Eff es (Either CommandError (Keiki.InFlight s co, RegFile rs, Maybe RecordedEvent)) + replayPage (Left err) _ = pure (Left err) + replayPage (Right (wrapper, registers, previousRecorded)) page = + pure $ case Keiki.replayEvents (eventStream ^. #transducer) (wrapper, registers) decodedEvents of + Left replayFailure -> + Left (hydrationReplayError previousRecorded decodedRecorded replayFailure) + Right (nextWrapper, nextRegisters) -> + case pendingInputFailure of + Just err -> Left err + Nothing -> + Right + ( nextWrapper + , nextRegisters + , latestRecorded decodedRecorded previousRecorded + ) + where + (decodedRecorded, decodedEvents, pendingInputFailure) = decodePrefix previousRecorded page + + decodePrefix :: Maybe RecordedEvent -> [RecordedEvent] -> ([RecordedEvent], [co], Maybe CommandError) + decodePrefix previousRecorded = go [] [] startingVersion + where + startingVersion = maybe seedVersion (^. #streamVersion) previousRecorded + + go recordedAcc eventAcc lastSeen = \case + [] -> (Prelude.reverse recordedAcc, Prelude.reverse eventAcc, Nothing) + recorded : rest -> + let observed = recorded ^. #streamVersion + expected = nextStreamVersion lastSeen + in if observed /= expected + then + ( Prelude.reverse recordedAcc + , Prelude.reverse eventAcc + , Just (HydrationGapDetected expected observed) + ) + else case decodeRecorded (eventStream ^. #eventCodec) recorded of + Left err -> + ( Prelude.reverse recordedAcc + , Prelude.reverse eventAcc + , Just (HydrationDecodeFailed err) + ) + Right event -> + go (recorded : recordedAcc) (event : eventAcc) observed rest + + nextStreamVersion (StreamVersion version) = StreamVersion (version Prelude.+ 1) + + hydrationReplayError :: + Maybe RecordedEvent -> + [RecordedEvent] -> + Keiki.ReplayFailure s co -> + CommandError + hydrationReplayError previousRecorded decodedRecorded replayFailure = + HydrationReplayFailed failureVersion (toHydrationReason (Keiki.replayFailureReason replayFailure)) + where + failureVersion = + maybe seedVersion (^. #streamVersion) failureRecorded + failureRecorded = + case Keiki.replayFailureReason replayFailure of + Keiki.ReplayLogTruncated{} -> latestRecorded decodedRecorded previousRecorded + Keiki.ReplayEventFailed{} -> + case recordedAt (Keiki.replayFailedIndex replayFailure) decodedRecorded of + Just recorded -> Just recorded + Nothing -> latestRecorded decodedRecorded previousRecorded + + finishReplay = \case + Left err -> Left err + Right (wrapper, finalRegisters, lastRecorded) -> + case wrapper of + Keiki.Settled finalState -> + Right + Hydrated + { state = finalState + , registers = finalRegisters + , streamVersion = maybe seedVersion (^. #streamVersion) lastRecorded + } + Keiki.InFlight{} -> + Left + ( HydrationReplayFailed + (maybe seedVersion (^. #streamVersion) lastRecorded) + HydrationTruncatedChain + ) + + toHydrationReason = \case + Keiki.ReplayEventFailed stepFailure -> case stepFailure of + Keiki.ReplayNoInvertingEdge{} -> HydrationNoInvertingEdge + Keiki.ReplayAmbiguousInversions{} -> HydrationAmbiguousInversion + Keiki.ReplayQueueMismatch{} -> HydrationQueueMismatch + Keiki.ReplayLogTruncated{} -> HydrationTruncatedChain + + latestRecorded recorded fallback = + case lastMaybe recorded of + Just latest -> Just latest + Nothing -> fallback + + lastMaybe = \case + [] -> Nothing + first : rest -> Just (Prelude.foldl (\_ current -> current) first rest) + + recordedAt eventIndex recorded = + case Prelude.drop eventIndex recorded of + found : _ -> Just found + [] -> Nothing + +{- | Hydrate the target stream, transduce the command, and append any emitted +events. Retries optimistic-concurrency conflicts up to 'retryLimit'. This +is the plain runner with no in-transaction side effects. +-} +runCommand :: + forall phi rs s ci co es. + (HasCallStack, IOE :> es, Store :> es, Error StoreError :> es, BoolAlg phi (RegFile rs, ci), Eq co) => + RunCommandOptions -> + ValidatedEventStream phi rs s ci co -> + Stream (EventStream phi rs s ci co) -> + ci -> + Eff es (Either CommandError (CommandResult (EventStream phi rs s ci co))) +runCommand options validatedEventStream targetStream command = + withCommandSpan (options ^. #tracer) (resolvedStreamName eventStream targetStream) Nothing $ \mSpan -> do + (result, attemptNo) <- attempt mSpan 1 Nothing + recordCommandOutcome mSpan (^. #eventsAppended) attemptNo result + pure result + where + eventStream = unvalidated validatedEventStream + + attempt mSpan attemptNo lastConflict = do + hydrated <- hydrate options eventStream targetStream + either (\err -> pure (Left err, attemptNo)) (runPlan mSpan attemptNo lastConflict) hydrated + + runPlan mSpan attemptNo lastConflict current = + case conflictFixpoint lastConflict (current ^. #streamVersion) of + Just err -> pure (Left err, attemptNo) + Nothing -> + case prepareCommandPlan options eventStream targetStream current command of + Left err -> pure (Left err, attemptNo) + Right (CommandNoOp result) -> pure (Right result, attemptNo) + Right (CommandAppend current' events encoded) -> + appendOnce mSpan attemptNo current' events encoded + + appendOnce mSpan attemptNo current events encoded = do + liftIO (options ^. #beforeAppend) + appended <- + tryError @StoreError + $ appendToStream + ((eventStream ^. #resolveStreamName) targetStream) + (expectedVersion (current ^. #streamVersion)) + encoded + case appended of + Right appendResult -> do + verifyAndSnapshot options mSpan eventStream current events appendResult + pure (Right (appendedResult targetStream appendResult (Prelude.length encoded)), attemptNo) + Left (_, storeError) -> + retryOrFail options (attempt mSpan) attemptNo (current ^. #streamVersion) storeError + +{- | Like 'runCommand', but run @afterAppend@ inside the /same/ transaction +as the append, so a read-model write commits atomically with the events. +The callback's result is returned as @Just@ on append (and 'Nothing' for a +no-op command that appended nothing). + +Requires 'KirokuStoreResource' so the transactional append applies the +configured @enrichEvent@ hook. See 'runCommandWithSqlEvents' for the callback's +locking and latency implications. +-} +runCommandWithSql :: + forall phi rs s ci co a es. + (HasCallStack, IOE :> es, Store :> es, Error StoreError :> es, KirokuStoreResource :> es, BoolAlg phi (RegFile rs, ci), Eq co) => + RunCommandOptions -> + ValidatedEventStream phi rs s ci co -> + Stream (EventStream phi rs s ci co) -> + ci -> + (AppendResult -> Tx.Transaction a) -> + Eff es (Either CommandError (CommandResult (EventStream phi rs s ci co), Maybe a)) +runCommandWithSql options eventStream targetStream command afterAppend = + runCommandWithSqlEvents options eventStream targetStream command (\_ appendResult -> afterAppend appendResult) + +{- | The most general runner: like 'runCommandWithSql', but the +in-transaction callback also receives every emitted event paired with the +'RecordedEvent' the store persisted for it, in append order. Inline +projections, process managers, and routers are all built on this. + +The runner requires 'KirokuStoreResource' and applies the configured +@enrichEvent@ hook before preparing the append. The callback therefore sees +the enriched metadata that was persisted. + +The append updates Kiroku's global @$all@ stream and holds its PostgreSQL row +lock until this transaction commits. Every SQL operation in the callback +therefore extends the store-wide append serialization window. Keep the +callback small: precompute outside the transaction where possible, batch +writes, and minimize database round trips. +-} +runCommandWithSqlEvents :: + forall phi rs s ci co a es. + (HasCallStack, IOE :> es, Store :> es, Error StoreError :> es, KirokuStoreResource :> es, BoolAlg phi (RegFile rs, ci), Eq co) => + RunCommandOptions -> + ValidatedEventStream phi rs s ci co -> + Stream (EventStream phi rs s ci co) -> + ci -> + ([(co, RecordedEvent)] -> AppendResult -> Tx.Transaction a) -> + Eff es (Either CommandError (CommandResult (EventStream phi rs s ci co), Maybe a)) +runCommandWithSqlEvents options validatedEventStream targetStream command afterAppend = + withCommandSpan (options ^. #tracer) (resolvedStreamName eventStream targetStream) Nothing $ \mSpan -> do + (result, attemptNo) <- attempt mSpan 1 Nothing + recordCommandOutcome mSpan (\(r, _) -> r ^. #eventsAppended) attemptNo result + pure result + where + eventStream = unvalidated validatedEventStream + + attempt mSpan attemptNo lastConflict = do + hydrated <- hydrate options eventStream targetStream + either (\err -> pure (Left err, attemptNo)) (runPlan mSpan attemptNo lastConflict) hydrated + + runPlan mSpan attemptNo lastConflict current = + case conflictFixpoint lastConflict (current ^. #streamVersion) of + Just err -> pure (Left err, attemptNo) + Nothing -> + case prepareCommandPlan options eventStream targetStream current command of + Left err -> pure (Left err, attemptNo) + Right (CommandNoOp result) -> pure (Right (result, Nothing), attemptNo) + Right (CommandAppend current' events encoded) -> + appendWithSqlOnce mSpan attemptNo current' events encoded + + appendWithSqlOnce mSpan attemptNo current events encoded = do + liftIO (options ^. #beforeAppend) + store <- getKirokuStore + enriched <- liftIO (enrichEventsIO store encoded) + prepared <- prepareEventsIO enriched + now <- liftIO getCurrentTime + let streamName = (eventStream ^. #resolveStreamName) targetStream + expected = expectedVersion (current ^. #streamVersion) + body = do + appended <- appendToStreamTx streamName expected prepared now + case appended of + Left conflict -> + Tx.condemn $> Left (appendConflictToStoreError conflict) + Right appendResult -> do + let recordeds = reconstructRecorded appendResult now prepared + userValue <- afterAppend (Prelude.zip events recordeds) appendResult + pure (Right (appendResult, userValue)) + outcome <- tryError @StoreError (runTransaction body) + case outcome of + Right (Right (appendResult, userValue)) -> do + verifyAndSnapshot options mSpan eventStream current events appendResult + pure (Right (appendedResult targetStream appendResult (Prelude.length encoded), Just userValue), attemptNo) + Right (Left storeError) -> + retryOrFail options (attempt mSpan) attemptNo (current ^. #streamVersion) storeError + Left (_, storeError) -> + retryOrFail options (attempt mSpan) attemptNo (current ^. #streamVersion) storeError + +prepareCommandPlan :: + (BoolAlg phi (RegFile rs, ci)) => + RunCommandOptions -> + EventStream phi rs s ci co -> + Stream (EventStream phi rs s ci co) -> + Hydrated rs s -> + ci -> + Either CommandError (CommandPlan (EventStream phi rs s ci co) rs s co) +prepareCommandPlan options eventStream targetStream current command = + case evaluateCommand eventStream current command of + Left err -> Left err + Right events -> toPlan events + where + toPlan [] = + Right (CommandNoOp (noOpResult targetStream current)) + toPlan events = + CommandAppend current events + . assignEventIds (options ^. #eventIds) + <$> encodeEvents (eventStream ^. #eventCodec) (options ^. #metadata) events + +{- | Render the stream that the command targets as plain 'Text', for use +as a span name. +-} +resolvedStreamName :: + EventStream phi rs s ci co -> + Stream (EventStream phi rs s ci co) -> + Text +resolvedStreamName eventStream targetStream = + case (eventStream ^. #resolveStreamName) targetStream of + StreamName n -> n + +{- | Attach the command-span outcome attributes after the runner returns. + +On success: 'db.system.name' and 'keiro.events.appended'. +On failure: 'error.type' (low-cardinality classifier) and span status +'Error' (carrying the rendered 'CommandError' as the description). + +Pure no-op when no span is active ('Nothing' tracer, etc). +-} +recordCommandOutcome :: + (IOE :> es) => + Maybe Span -> + (a -> Int) -> + Int -> + Either CommandError a -> + Eff es () +recordCommandOutcome Nothing _ _ _ = pure () +recordCommandOutcome (Just sp) eventsOf attemptNo result = do + addAttribute sp (unkey db_system_name) ("postgresql" :: Text) + addAttribute sp (unkey keiro_retry_attempt) (Prelude.fromIntegral attemptNo :: Int64) + case result of + Right v -> + addAttribute sp (unkey keiro_events_appended) (Prelude.fromIntegral (eventsOf v) :: Int64) + Left err -> do + addAttribute sp (unkey error_type) (commandErrorClass err) + setStatus sp (Error (Text.take 256 (Text.pack (show err)))) + +{- | Low-cardinality classifier for a 'CommandError'. Used as the +@error.type@ attribute value on the command span. +-} +commandErrorClass :: CommandError -> Text +commandErrorClass = \case + HydrationDecodeFailed{} -> "hydration_decode_failed" + HydrationReplayFailed _ HydrationNoInvertingEdge -> "hydration_replay_no_inverting_edge" + HydrationReplayFailed _ HydrationAmbiguousInversion -> "hydration_replay_ambiguous_inversion" + HydrationReplayFailed _ HydrationQueueMismatch -> "hydration_replay_queue_mismatch" + HydrationReplayFailed _ HydrationTruncatedChain -> "hydration_replay_truncated_chain" + HydrationGapDetected{} -> "hydration_gap_detected" + CommandRejected -> "command_rejected" + CommandAmbiguous{} -> "command_ambiguous" + EncodeFailed{} -> "encode_failed" + StoreFailed{} -> "store_failed" + RetryExhausted{} -> "retry_exhausted" + ConflictFixpoint{} -> "conflict_fixpoint" + +verifyAndSnapshot :: + forall phi rs s ci co es. + (BoolAlg phi (RegFile rs, ci), IOE :> es, Store :> es, Error StoreError :> es, Eq co) => + RunCommandOptions -> + Maybe Span -> + EventStream phi rs s ci co -> + Hydrated rs s -> + [co] -> + AppendResult -> + Eff es () +verifyAndSnapshot options mSpan eventStream current events appendResult + | Prelude.not (options ^. #verifyReplayOnAppend) + , Nothing <- eventStream ^. #stateCodec = + pure () + | otherwise = + case Keiki.applyEventsEither (eventStream ^. #transducer) (state current, registers current) events of + Left failure -> do + recordSnapshotApplyDivergence (options ^. #metrics) 1 + for_ mSpan $ \sp -> + addAttribute + sp + (unkey keiro_replay_divergence) + (Text.take 256 (renderReplayFailure failure)) + Right finalState -> + case eventStream ^. #stateCodec of + Nothing -> pure () + Just codec -> do + let finalVersion = appendResult ^. #streamVersion + terminality = + if Keiki.isFinal (eventStream ^. #transducer) (Prelude.fst finalState) + then Terminal + else NotTerminal + when (shouldSnapshotSpan (eventStream ^. #snapshotPolicy) terminality finalState (current ^. #streamVersion) finalVersion) + $ do + encoded <- liftIO (encodeSnapshotStrict codec finalState) + case encoded of + Left _ -> recordSnapshotEncodeFailures (options ^. #metrics) 1 + Right value -> do + outcome <- tryError @StoreError (writeSnapshotEncoded (appendResult ^. #streamId) finalVersion codec value) + case outcome of + Right () -> pure () + Left _ -> recordSnapshotWriteFailures (options ^. #metrics) 1 + +renderReplayFailure :: Keiki.ReplayFailure s co -> Text +renderReplayFailure failure = + "event_index=" + <> Text.pack (show (Keiki.replayFailedIndex failure)) + <> ";reason=" + <> case Keiki.replayFailureReason failure of + Keiki.ReplayEventFailed stepFailure -> case stepFailure of + Keiki.ReplayNoInvertingEdge{} -> "no_inverting_edge" + Keiki.ReplayAmbiguousInversions{} -> "ambiguous_inversions" + Keiki.ReplayQueueMismatch{} -> "queue_mismatch" + Keiki.ReplayLogTruncated{} -> "log_truncated" + +retryOrFail :: + (IOE :> es) => + RunCommandOptions -> + (Int -> Maybe (StoreError, StreamVersion) -> Eff es (Either CommandError a, Int)) -> + Int -> + StreamVersion -> + StoreError -> + Eff es (Either CommandError a, Int) +retryOrFail options retry attemptNo observedVersion storeError + | isRetryableConflict storeError + , attemptNo <= options ^. #retryLimit = do + recordCommandConflicts (options ^. #metrics) 1 + backoffDelay options attemptNo + recordCommandRetries (options ^. #metrics) 1 + retry (attemptNo Prelude.+ 1) (Just (storeError, observedVersion)) + | isRetryableConflict storeError = do + recordCommandConflicts (options ^. #metrics) 1 + pure (Left (RetryExhausted attemptNo storeError), attemptNo) + | otherwise = do + case storeError of + DuplicateEvent{} -> recordCommandDuplicates (options ^. #metrics) 1 + _ -> pure () + pure (Left (StoreFailed storeError), attemptNo) + +backoffDelay :: (IOE :> es) => RunCommandOptions -> Int -> Eff es () +backoffDelay options attemptNo + | base <= 0 = pure () + | otherwise = do + nanos <- liftIO getMonotonicTimeNSec + let exponential = min 100000 (base Prelude.* (2 Prelude.^ (attemptNo Prelude.- 1 :: Int))) + jitter = + Prelude.fromIntegral (nanos `Prelude.mod` Prelude.fromIntegral exponential) + Prelude.- (exponential `Prelude.div` 2) + liftIO (threadDelay (max 0 (exponential Prelude.+ jitter))) + where + base = options ^. #retryBackoffMicros + +conflictFixpoint :: Maybe (StoreError, StreamVersion) -> StreamVersion -> Maybe CommandError +conflictFixpoint (Just (previousError@StreamAlreadyExists{}, previousVersion)) currentVersion + | currentVersion == previousVersion = Just (ConflictFixpoint currentVersion previousError) +conflictFixpoint _ _ = Nothing + +evaluateCommand :: + (BoolAlg phi (RegFile rs, ci)) => + EventStream phi rs s ci co -> + Hydrated rs s -> + ci -> + Either CommandError [co] +evaluateCommand eventStream current command = + case Keiki.stepEither (eventStream ^. #transducer) (state current, registers current) command of + Left Keiki.NoOutgoingEdges{} -> Left CommandRejected + Left Keiki.NoMatchingEdge{} -> Left CommandRejected + Left (Keiki.AmbiguousEdges _ matches) -> + Left + ( CommandAmbiguous + [ Keiki.edgeIndex (Keiki.matchedEdge matched) + | matched <- matches + ] + ) + Right (_, _, events) -> Right events + +encodeEvents :: Codec co -> Maybe Value -> [co] -> Either CommandError [EventData] +encodeEvents codec md = + Prelude.mapM (mapLeft EncodeFailed . encodeForAppendWithMetadata codec md) + +assignEventIds :: [EventId] -> [EventData] -> [EventData] +assignEventIds [] events = events +assignEventIds _ [] = [] +assignEventIds (supplied : suppliedRest) (event : eventRest) = + (event & #eventId .~ Just supplied) : assignEventIds suppliedRest eventRest + +expectedVersion :: StreamVersion -> ExpectedVersion +expectedVersion (StreamVersion 0) = NoStream +expectedVersion version = ExactVersion version + +noOpResult :: + Stream target -> + Hydrated rs s -> + CommandResult target +noOpResult targetStream current = + CommandResult + { target = targetStream + , streamVersion = current ^. #streamVersion + , globalPosition = Nothing + , eventsAppended = 0 + } + +appendedResult :: + Stream target -> + AppendResult -> + Int -> + CommandResult target +appendedResult targetStream appendResult count = + CommandResult + { target = targetStream + , streamVersion = appendResult ^. #streamVersion + , globalPosition = Just (appendResult ^. #globalPosition) + , eventsAppended = count + } + +{- | Rebuild the per-event 'RecordedEvent' values for a just-appended batch. + +The store assigns each event in a batch a contiguous stream version and +global position: event @i@ (1-based) gets @last - count + i@ for both +counters, where @last@ is the position the 'AppendResult' reports for the +final event and @count@ is the batch size. (The kiroku append SQL numbers +events with @WITH ORDINALITY@ and inserts @initial + idx@; see EP-27's +Surprises & Discoveries.) We therefore reconstruct each 'RecordedEvent' +exactly, rather than reading the batch back. The @createdAt@ is the same +timestamp 'prepareEventsIO'/'appendToStreamTx' used for the insert. + +This is a source append (events are written to their own stream), so +@streamVersion == originalVersion@ and @originalStreamId@ is the appended +stream's id, per the 'RecordedEvent' contract. +-} +reconstructRecorded :: AppendResult -> UTCTime -> [PreparedEvent] -> [RecordedEvent] +reconstructRecorded appendResult now prepared = + Prelude.zipWith mk [0 ..] prepared + where + count = Prelude.length prepared + StreamVersion lastSv = appendResult ^. #streamVersion + GlobalPosition lastGp = appendResult ^. #globalPosition + firstSv = lastSv Prelude.- Prelude.fromIntegral count Prelude.+ 1 + firstGp = lastGp Prelude.- Prelude.fromIntegral count Prelude.+ 1 + mk :: Int64 -> PreparedEvent -> RecordedEvent + mk i prepared' = + RecordedEvent + { eventId = EventId (prepared' ^. #peEventId) + , eventType = prepared' ^. #peEventType + , streamVersion = StreamVersion (firstSv Prelude.+ i) + , globalPosition = GlobalPosition (firstGp Prelude.+ i) + , originalStreamId = appendResult ^. #streamId + , originalVersion = StreamVersion (firstSv Prelude.+ i) + , payload = prepared' ^. #pePayload + , metadata = prepared' ^. #peMetadata + , causationId = prepared' ^. #peCausationId + , correlationId = prepared' ^. #peCorrelationId + , createdAt = now + } + +isRetryableConflict :: StoreError -> Bool +isRetryableConflict = \case + WrongExpectedVersion{} -> True + StreamAlreadyExists{} -> True + _ -> False + +mapLeft :: (e -> e') -> Either e a -> Either e' a +mapLeft f = \case + Left err -> Left (f err) + Right value -> Right value diff --git a/src/Keiro/Connection.hs b/src/Keiro/Connection.hs new file mode 100644 --- /dev/null +++ b/src/Keiro/Connection.hs @@ -0,0 +1,100 @@ +{- | Schema-resolution helpers for application read-model and projection tables. + +Keiro's own framework tables live in the dedicated @keiro@ schema and its +runtime queries are fully qualified there. This module is about the /third/ +layer: where an application's read-model /data/ tables live, and how the +application declares and reaches that location. + +A PostgreSQL /schema/ is a namespace of tables inside one database. Because +Keiro opens its database pool through kiroku's connection settings — whose +@search_path@ starts with the event store's private @kiroku@ schema — an +unqualified @CREATE TABLE my_read_model (...)@ would land the table inside the +@kiroku@ event-store schema. To place it elsewhere, the application must +qualify at least its @CREATE TABLE@ as @schema.table@ (an unqualified create +always lands in the first @search_path@ entry). Qualifying the read/write SQL +too makes everything correct regardless of @search_path@ — the robust default. + +This module gives applications exactly one convention: + +* 'qualifyTable' builds a double-quoted, schema-qualified table reference to + interpolate into projection SQL. +* 'withProjectionSchema' / 'keiroConnectionSettings' wire the store connection + so a chosen projection schema also /resolves/ on the pool (via kiroku's + @extraSearchPath@), for applications that also want unqualified SQL to work. +* 'ensureProjectionSchema' is an opt-in @CREATE SCHEMA IF NOT EXISTS@ helper for + development, tests, and worked examples; Keiro never calls it automatically. + +The kiroku store connection's @schema@ field stays @kiroku@ and is never +repointed: it also drives the @.events@ @LISTEN@/@NOTIFY@ channel, so +changing it would break subscription wake-ups. The projection schema is reached +only by qualification and\/or @extraSearchPath@. +-} +module Keiro.Connection ( + qualifyTable, + quoteIdentifier, + withProjectionSchema, + keiroConnectionSettings, + ensureProjectionSchema, +) +where + +import Data.Text qualified as T +import Data.Text.Encoding qualified as TE +import Effectful (Eff, (:>)) +import Keiro.Prelude +import Kiroku.Store.Connection (ConnectionSettings, defaultConnectionSettings) +import Kiroku.Store.Effect (Store) +import Kiroku.Store.Transaction (runTransaction) +import "hasql-transaction" Hasql.Transaction qualified as Tx + +{- | Build a double-quoted, schema-qualified table reference @"schema"."table"@, +doubling any embedded double quotes (the same identifier quoting kiroku uses). +Interpolate the result directly into projection SQL, e.g. + +@ +"SELECT ... FROM " <> qualifyTable "app" "orders" <> " WHERE ..." +@ +-} +qualifyTable :: Text -> Text -> Text +qualifyTable schema table = quoteIdentifier schema <> "." <> quoteIdentifier table + +{- | Double-quote a single SQL identifier, doubling any embedded double quotes +(the same identifier quoting kiroku uses). Useful for building qualified names +or a @CREATE SCHEMA ""@ statement. +-} +quoteIdentifier :: Text -> Text +quoteIdentifier ident = "\"" <> T.replace "\"" "\"\"" ident <> "\"" + +{- | Append @projectionSchema@ to a settings value's @extraSearchPath@ so a +pooled connection can /resolve/ (read\/write) application tables in that schema. +Idempotent: the schema is appended only if not already present. The store's +@schema@ field is left untouched (stays @kiroku@). +-} +withProjectionSchema :: Text -> ConnectionSettings -> ConnectionSettings +withProjectionSchema projectionSchema settings = + settings & #extraSearchPath %~ appendUnique projectionSchema + where + appendUnique s xs + | s `elem` xs = xs + | otherwise = xs <> [s] + +{- | kiroku's default connection settings (@schema = "kiroku"@) with +@projectionSchema@ added to @extraSearchPath@, so unqualified application +data-manipulation SQL resolves on the store pool while the store @schema@ stays +@kiroku@ (honoring the NOTIFY-channel constraint). This does /not/ bake Keiro's +own @keiro@ schema into @extraSearchPath@: Keiro's runtime queries are already +fully qualified and must not depend on @search_path@. +-} +keiroConnectionSettings :: Text -> Text -> ConnectionSettings +keiroConnectionSettings connString projectionSchema = + withProjectionSchema projectionSchema (defaultConnectionSettings connString) + +{- | Run @CREATE SCHEMA IF NOT EXISTS ""@ 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)) diff --git a/src/Keiro/DeadLetter.hs b/src/Keiro/DeadLetter.hs new file mode 100644 --- /dev/null +++ b/src/Keiro/DeadLetter.hs @@ -0,0 +1,35 @@ +{- | Durable records for process-manager and router dispatches rejected by a +target state machine. + +Use 'recordDispatchDeadLetter' from a worker before acknowledging its source +event, and 'listDispatchDeadLetters' to inspect the durable witnesses for one +dispatcher. Inserts are idempotent under source-event redelivery. +-} +module Keiro.DeadLetter ( + DispatcherKind (..), + DispatchDeadLetter (..), + DispatchDeadLetterRecord (..), + recordDispatchDeadLetter, + listDispatchDeadLetters, +) +where + +import Effectful (Eff, (:>)) +import Keiro.DeadLetter.Schema ( + DispatchDeadLetter (..), + DispatchDeadLetterRecord (..), + DispatcherKind (..), + listDispatchDeadLettersTx, + recordDispatchDeadLetterTx, + ) +import Keiro.Prelude +import Kiroku.Store.Effect (Store) +import Kiroku.Store.Transaction (runTransaction) + +-- | Idempotently persist one rejected dispatch. +recordDispatchDeadLetter :: (Store :> es) => DispatchDeadLetter -> Eff es () +recordDispatchDeadLetter = runTransaction . recordDispatchDeadLetterTx + +-- | List one dispatcher's rejected dispatches, newest first. +listDispatchDeadLetters :: (Store :> es) => Text -> Eff es [DispatchDeadLetterRecord] +listDispatchDeadLetters = runTransaction . listDispatchDeadLettersTx diff --git a/src/Keiro/DeadLetter/Replay.hs b/src/Keiro/DeadLetter/Replay.hs new file mode 100644 --- /dev/null +++ b/src/Keiro/DeadLetter/Replay.hs @@ -0,0 +1,148 @@ +{- | Operator replay for source events parked in Kiroku's +@kiroku.dead_letters@ table. + +The rows remain Kiroku-owned: replay neither deletes nor marks them. Instead it +re-runs a caller-supplied handler and relies on that handler's idempotency. This +is safe for "Keiro.ProcessManager" and "Keiro.Router" handlers because their +writes use deterministic event identifiers derived from the source event; +already-applied writes collapse to duplicate outcomes on every later replay. + +Kiroku exposes dead-letter rows by event id and global position, but does not +currently expose an exact point-read by either value. Global positions are +opaque cursors and must never be decremented. 'replaySubscriptionDeadLetters' +therefore scans the global stream backward using only @0@ and cursors returned +by Kiroku, matches both event id and position, and scans once for the whole +batch. A source event removed by hard deletion is reported as +'ReplaySourceMissing' and is not handed to the caller. + +A process-manager handler normally decodes the recorded event, calls +@runProcessManagerOnce@, and classifies a result whose manager state and every +target command are duplicates as 'ReplayedDuplicate'; any append makes it +'ReplayedFresh'. Return @Left detail@ for a decode or command failure. For +example, the classification has this shape: + +> case result of +> Left err -> Left (showText err) +> Right pmResult +> | managerAndEveryCommandAreDuplicates pmResult -> Right ReplayedDuplicate +> | otherwise -> Right ReplayedFresh + +Because rows are retained, an operator may safely run the same replay command +again after a partial failure or uncertain client disconnect. +-} +module Keiro.DeadLetter.Replay ( + ReplayOutcome (..), + ReplayResult (..), + DeadLetterRecord (..), + listSubscriptionDeadLetters, + replaySubscriptionDeadLetters, +) +where + +import Data.Int (Int32) +import Data.Map.Strict (Map) +import Data.Map.Strict qualified as Map +import Data.Vector (Vector) +import Data.Vector qualified as Vector +import Effectful (Eff, (:>)) +import Keiro.Prelude +import Kiroku.Store.Effect (Store) +import Kiroku.Store.Read (readAllBackward) +import Kiroku.Store.SQL (DeadLetterRecord (..), readDeadLettersStmt) +import Kiroku.Store.Subscription.Types (SubscriptionName (..)) +import Kiroku.Store.Transaction (runTransaction) +import Kiroku.Store.Types (EventId (..), GlobalPosition (..), RecordedEvent) +import "hasql-transaction" Hasql.Transaction qualified as Tx + +data ReplayOutcome = ReplayOutcome + { replayGlobalPosition :: !GlobalPosition + , replayEventId :: !EventId + , replayResult :: !ReplayResult + } + deriving stock (Generic, Eq, Show) + +data ReplayResult + = ReplayedFresh + | ReplayedDuplicate + | ReplayFailed !Text + | ReplaySourceMissing + deriving stock (Generic, Eq, Show) + +-- | List one Kiroku subscription member's dead letters, newest first. +listSubscriptionDeadLetters :: + (Store :> es) => SubscriptionName -> Int32 -> Eff es (Vector DeadLetterRecord) +listSubscriptionDeadLetters (SubscriptionName name) member = + runTransaction (Tx.statement (name, member) readDeadLettersStmt) + +{- | Replay every dead letter currently listed for one subscription member. + +The handler controls domain-specific decoding and decides whether its writes +were fresh or duplicates. A @Left detail@ is recorded in the corresponding +'ReplayOutcome' as 'ReplayFailed'; replay continues with later rows. Store +errors still surface through the surrounding Kiroku 'Store' interpreter. +-} +replaySubscriptionDeadLetters :: + (Store :> es) => + SubscriptionName -> + Int32 -> + (RecordedEvent -> Eff es (Either Text ReplayResult)) -> + Eff es [ReplayOutcome] +replaySubscriptionDeadLetters subscriptionName member handler = do + rows <- listSubscriptionDeadLetters subscriptionName member + sources <- findSources rows + traverse (replayOne sources) (Vector.toList rows) + where + replayOne sources row = do + let position = deadLetterPosition row + eventId = deadLetterEventIdValue row + result <- case Map.lookup eventId sources of + Just event + | event ^. #globalPosition == position -> do + handled <- handler event + pure (either ReplayFailed id handled) + _ -> pure ReplaySourceMissing + pure + ReplayOutcome + { replayGlobalPosition = position + , replayEventId = eventId + , replayResult = result + } + +-- Scan once for the complete replay batch. Pages are descending, and the next +-- cursor is always a position Kiroku returned; no global-position arithmetic. +findSources :: + (Store :> es) => Vector DeadLetterRecord -> Eff es (Map EventId RecordedEvent) +findSources rows = go (GlobalPosition 0) Map.empty + where + wanted = + Map.fromList + [ (deadLetterEventIdValue row, deadLetterPosition row) + | row <- Vector.toList rows + ] + + go cursor found + | Map.size found == Map.size wanted = pure found + | otherwise = do + page <- readAllBackward cursor replayReadPageSize + if Vector.null page + then pure found + else do + let found' = Vector.foldl' remember found page + nextCursor = Vector.last page ^. #globalPosition + go nextCursor found' + + remember found event = + case Map.lookup (event ^. #eventId) wanted of + Just expectedPosition + | event ^. #globalPosition == expectedPosition -> + Map.insert (event ^. #eventId) event found + _ -> found + +replayReadPageSize :: Int32 +replayReadPageSize = 256 + +deadLetterPosition :: DeadLetterRecord -> GlobalPosition +deadLetterPosition row = GlobalPosition (row ^. #deadLetterGlobalPosition) + +deadLetterEventIdValue :: DeadLetterRecord -> EventId +deadLetterEventIdValue row = EventId (row ^. #deadLetterEventId) diff --git a/src/Keiro/DeadLetter/Schema.hs b/src/Keiro/DeadLetter/Schema.hs new file mode 100644 --- /dev/null +++ b/src/Keiro/DeadLetter/Schema.hs @@ -0,0 +1,171 @@ +{- | SQL storage for rejected process-manager and router dispatches. + +The @keiro.keiro_dead_letters@ table records a dispatched command that a +target state machine rejected. It is deliberately separate from Kiroku's +subscription dead-letter table: a row here describes one failed dispatch, +while the source subscription event is considered handled and may advance its +checkpoint. +-} +module Keiro.DeadLetter.Schema ( + DispatcherKind (..), + DispatchDeadLetter (..), + DispatchDeadLetterRecord (..), + recordDispatchDeadLetterTx, + listDispatchDeadLettersTx, +) +where + +import Contravariant.Extras (contrazip10) +import Data.Int (Int32) +import Data.Text qualified as Text +import Data.UUID (UUID) +import Hasql.Decoders qualified as D +import Hasql.Encoders qualified as E +import Hasql.Statement (Statement, preparable) +import Keiro.Prelude +import Kiroku.Store.Types (EventId (..), GlobalPosition (..), StreamName (..)) +import "hasql-transaction" Hasql.Transaction qualified as Tx +import Prelude (fromIntegral) + +-- | Which coordination primitive attempted the rejected dispatch. +data DispatcherKind + = DispatcherProcessManager + | DispatcherRouter + deriving stock (Generic, Eq, Ord, Show) + +-- | Fields persisted for one rejected dispatch. +data DispatchDeadLetter = DispatchDeadLetter + { dispatcherKind :: !DispatcherKind + , dispatcherName :: !Text + , correlationId :: !Text + , sourceEventId :: !EventId + , sourceGlobalPosition :: !GlobalPosition + , emitIndex :: !Int + , targetStreamName :: !StreamName + , errorClass :: !Text + , errorDetail :: !Text + , attemptCount :: !Int + } + deriving stock (Generic, Eq, Show) + +-- | A persisted rejected dispatch, including database-managed identity and time. +data DispatchDeadLetterRecord = DispatchDeadLetterRecord + { deadLetterId :: !Int64 + , dispatcherKind :: !DispatcherKind + , dispatcherName :: !Text + , correlationId :: !Text + , sourceEventId :: !EventId + , sourceGlobalPosition :: !GlobalPosition + , emitIndex :: !Int + , targetStreamName :: !StreamName + , errorClass :: !Text + , errorDetail :: !Text + , attemptCount :: !Int + , createdAt :: !UTCTime + } + deriving stock (Generic, Eq, Show) + +{- | Insert a rejected dispatch inside the caller's transaction. Redelivery is +idempotent: a duplicate @(dispatcher_name, source_event_id, emit_index)@ is a +no-op. Error detail is bounded here so every caller gets the same 1024-character +storage contract. +-} +recordDispatchDeadLetterTx :: DispatchDeadLetter -> Tx.Transaction () +recordDispatchDeadLetterTx deadLetter = + Tx.statement (dispatchDeadLetterParams deadLetter) insertDispatchDeadLetterStmt + +-- | List one dispatcher's records, newest first. +listDispatchDeadLettersTx :: Text -> Tx.Transaction [DispatchDeadLetterRecord] +listDispatchDeadLettersTx dispatcher = + Tx.statement dispatcher listDispatchDeadLettersStmt + +insertDispatchDeadLetterStmt :: Statement (Text, Text, Text, UUID, Int64, Int32, Text, Text, Text, Int32) () +insertDispatchDeadLetterStmt = + preparable + """ + INSERT INTO keiro.keiro_dead_letters + (dispatcher_kind, dispatcher_name, correlation_id, source_event_id, + source_global_position, emit_index, target_stream_name, error_class, + error_detail, attempt_count) + VALUES + ($1, $2, $3, $4, $5, $6, $7, $8, $9, $10) + ON CONFLICT (dispatcher_name, source_event_id, emit_index) DO NOTHING + """ + ( contrazip10 + (E.param (E.nonNullable E.text)) + (E.param (E.nonNullable E.text)) + (E.param (E.nonNullable E.text)) + (E.param (E.nonNullable E.uuid)) + (E.param (E.nonNullable E.int8)) + (E.param (E.nonNullable E.int4)) + (E.param (E.nonNullable E.text)) + (E.param (E.nonNullable E.text)) + (E.param (E.nonNullable E.text)) + (E.param (E.nonNullable E.int4)) + ) + D.noResult + +listDispatchDeadLettersStmt :: Statement Text [DispatchDeadLetterRecord] +listDispatchDeadLettersStmt = + preparable + """ + SELECT dead_letter_id, dispatcher_kind, dispatcher_name, correlation_id, + source_event_id, source_global_position, emit_index, + target_stream_name, error_class, error_detail, attempt_count, + created_at + FROM keiro.keiro_dead_letters + WHERE dispatcher_name = $1 + ORDER BY created_at DESC, dead_letter_id DESC + """ + (E.param (E.nonNullable E.text)) + (D.rowList dispatchDeadLetterRecordDecoder) + +dispatchDeadLetterRecordDecoder :: D.Row DispatchDeadLetterRecord +dispatchDeadLetterRecordDecoder = + DispatchDeadLetterRecord + <$> D.column (D.nonNullable D.int8) + <*> D.column (D.nonNullable (D.refine dispatcherKindFromText D.text)) + <*> D.column (D.nonNullable D.text) + <*> D.column (D.nonNullable D.text) + <*> (EventId <$> D.column (D.nonNullable D.uuid)) + <*> (GlobalPosition <$> D.column (D.nonNullable D.int8)) + <*> (fromIntegral <$> D.column (D.nonNullable D.int4)) + <*> (StreamName <$> D.column (D.nonNullable D.text)) + <*> D.column (D.nonNullable D.text) + <*> D.column (D.nonNullable D.text) + <*> (fromIntegral <$> D.column (D.nonNullable D.int4)) + <*> D.column (D.nonNullable D.timestamptz) + +dispatchDeadLetterParams :: DispatchDeadLetter -> (Text, Text, Text, UUID, Int64, Int32, Text, Text, Text, Int32) +dispatchDeadLetterParams deadLetter = + ( dispatcherKindToText (deadLetter ^. #dispatcherKind) + , deadLetter ^. #dispatcherName + , deadLetter ^. #correlationId + , eventIdToUuid (deadLetter ^. #sourceEventId) + , globalPositionToInt64 (deadLetter ^. #sourceGlobalPosition) + , fromIntegral (deadLetter ^. #emitIndex) + , streamNameToText (deadLetter ^. #targetStreamName) + , deadLetter ^. #errorClass + , Text.take 1024 (deadLetter ^. #errorDetail) + , fromIntegral (deadLetter ^. #attemptCount) + ) + +dispatcherKindToText :: DispatcherKind -> Text +dispatcherKindToText = \case + DispatcherProcessManager -> "process-manager" + DispatcherRouter -> "router" + +dispatcherKindFromText :: Text -> Either Text DispatcherKind +dispatcherKindFromText = \case + "process-manager" -> Right DispatcherProcessManager + "router" -> Right DispatcherRouter + other -> Left ("unknown keiro_dead_letters.dispatcher_kind: " <> other) + +eventIdToUuid :: EventId -> UUID +eventIdToUuid (EventId uuid) = uuid + +globalPositionToInt64 :: GlobalPosition -> Int64 +globalPositionToInt64 (GlobalPosition position) = position + +streamNameToText :: StreamName -> Text +streamNameToText (StreamName name) = name diff --git a/src/Keiro/Inbox.hs b/src/Keiro/Inbox.hs new file mode 100644 --- /dev/null +++ b/src/Keiro/Inbox.hs @@ -0,0 +1,426 @@ +{- | Idempotent inbox for cross-bounded-context integration events. + +The inbox lives in the consuming bounded context. When a Kafka consumer +receives an integration event, the inbox records the event's stable +external identity and runs the local handler in the same Postgres +transaction. Duplicate redeliveries (Kafka offset retry, rebalance, +producer republish) become observable as duplicates instead of +re-running the handler. + +The wrapper is a single-transaction primitive: the completed inbox row +and the handler's local writes commit atomically. If the handler raises +or condemns the transaction, the inbox row never appears and the next +delivery starts fresh. + +Completed-row retention defines the deduplication window. After +'garbageCollectCompleted' removes a row, a later delivery of the same key is +processed again. A concurrent GC can also delete a conflicting completed row +between the insert attempt and its lookup; the handler then commits without a +replacement deduplication row, so a later redelivery can run it again. These +cases preserve at-least-once delivery, not permanent exactly-once processing; +size retention beyond the maximum redelivery delay and keep handlers +idempotent. +-} +module Keiro.Inbox ( + -- * Re-exports + module Keiro.Inbox.Types, + + -- * Storage primitives + lookupInbox, + listInbox, + garbageCollectCompleted, + countInboxBacklog, + markFailedTx, + + -- * Transactional handler wrapper + runInboxTransaction, + runInboxTransactionWith, + runInboxTransactionWithKey, + runInboxTransactionWithRetries, + runInboxTransactionWithRetriesWith, + runInboxTransactionWithRetriesKey, + runInboxTransactionBatch, + sampleInboxBacklog, +) +where + +import Data.Map.Strict qualified as Map +import Data.Maybe (listToMaybe, mapMaybe) +import Data.Text qualified as Text +import Effectful (Eff, IOE, (:>)) +import Effectful.Exception (displayException, trySync) +import Keiro.Inbox.Schema +import Keiro.Inbox.Types +import Keiro.Integration.Event (IntegrationEvent) +import Keiro.Prelude +import Keiro.Telemetry ( + KeiroMetrics, + recordInboxBacklog, + recordInboxDuplicates, + recordInboxFailed, + recordInboxPoisoned, + recordInboxProcessed, + ) +import Kiroku.Store.Effect (Store) +import Kiroku.Store.Transaction (runTransaction) +import "hasql-transaction" Hasql.Transaction qualified as Tx + +data BatchPlan + = BatchKeyError !InboxError + | BatchDuplicate + | BatchWork !Text !Text !IntegrationEvent !(Maybe KafkaDeliveryRef) + +{- | Run @handler@ at most once for each @(source, dedupe_key)@. + +Computes the dedupe key from @policy@ and @kafka@, then in one +transaction: + +* Inserts the inbox row with status @completed@. +* If the row already exists, branches on its status: 'InboxCompleted' + → 'InboxDuplicate'; 'InboxProcessing' → 'InboxInProgress'; + 'InboxFailed' → 'InboxPreviouslyFailed'. +* Otherwise runs @handler@; the row commits only if the handler succeeds. + +The handler is invoked with the decoded 'IntegrationEvent' so it does +not need to redecode bytes. On exception or 'Tx.condemn' the whole +transaction rolls back, including the inbox row insert — the next +delivery sees no row and can retry. +-} +runInboxTransaction :: + forall a es. + (IOE :> es, Store :> es) => + Maybe KeiroMetrics -> + InboxDedupePolicy -> + IntegrationEvent -> + Maybe KafkaDeliveryRef -> + (IntegrationEvent -> Tx.Transaction a) -> + Eff es (Either InboxError (InboxResult a)) +runInboxTransaction mMetrics policy event kafka handler = + runInboxTransactionWith mMetrics PersistFullEnvelope policy event kafka handler + +{- | Variant of 'runInboxTransaction' that controls success-path +envelope persistence. + +'PersistDedupeOnly' keeps enough columns for dedupe and operator +correlation but stores an empty payload and omits schema, trace, and +attribute columns for successfully processed rows. +-} +runInboxTransactionWith :: + forall a es. + (IOE :> es, Store :> es) => + Maybe KeiroMetrics -> + InboxPersistence -> + InboxDedupePolicy -> + IntegrationEvent -> + Maybe KafkaDeliveryRef -> + (IntegrationEvent -> Tx.Transaction a) -> + Eff es (Either InboxError (InboxResult a)) +runInboxTransactionWith mMetrics persistence policy event kafka handler = + case dedupeKeyFor policy event kafka of + Left err -> pure (Left err) + Right dedupe -> + Right + <$> runInboxTransactionWithKeyPersist + mMetrics + persistence + (event ^. #source) + dedupe + event + kafka + handler + +{- | Lower-level variant that takes the dedupe key directly. + +Use when the policy is not enough to express the identity scheme — for +example, when the consumer joins fields from multiple headers or +derives the key from the payload itself. +-} +runInboxTransactionWithKey :: + forall a es. + (IOE :> es, Store :> es) => + Maybe KeiroMetrics -> + Text -> + Text -> + IntegrationEvent -> + Maybe KafkaDeliveryRef -> + (IntegrationEvent -> Tx.Transaction a) -> + Eff es (InboxResult a) +runInboxTransactionWithKey mMetrics src dedupe event kafka handler = + runInboxTransactionWithKeyPersist mMetrics PersistFullEnvelope src dedupe event kafka handler + +runInboxTransactionWithKeyPersist :: + forall a es. + (IOE :> es, Store :> es) => + Maybe KeiroMetrics -> + InboxPersistence -> + Text -> + Text -> + IntegrationEvent -> + Maybe KafkaDeliveryRef -> + (IntegrationEvent -> Tx.Transaction a) -> + Eff es (InboxResult a) +runInboxTransactionWithKeyPersist mMetrics persistence src dedupe event kafka handler = do + now <- liftIO getCurrentTime + result <- + runTransaction $ + attemptOneTx persistence Nothing src dedupe event kafka now handler + -- Record the classification counter outside the handler transaction. + -- Backlog gauge sampling is intentionally scheduled separately via + -- 'sampleInboxBacklog'. + recordInboxResult mMetrics Nothing result + pure result + +{- | Run @handler@ with opt-in poison-message accounting. + +This wrapper behaves like 'runInboxTransaction' for fresh messages, +duplicates, and in-flight rows, but changes the behavior for handler +exceptions and previously failed rows: + +* A synchronous exception from @handler@ rolls back the handler + transaction, then records a failed attempt in a second transaction and + returns 'InboxHandlerFailed' with the new attempt count. +* A previously failed row with @attempt_count < ceiling@ is retried. +* A previously failed row with @attempt_count >= ceiling@ returns + 'InboxPreviouslyFailed' without running the handler. The consumer can + commit its offset and move on; the failed inbox row is the dead-letter + record for operator review. + +'Tx.condemn' is not treated as a handler failure by this wrapper. It +keeps the original rollback semantics from 'runInboxTransaction'. +-} +runInboxTransactionWithRetries :: + forall a es. + (IOE :> es, Store :> es) => + Maybe KeiroMetrics -> + Int -> + InboxDedupePolicy -> + IntegrationEvent -> + Maybe KafkaDeliveryRef -> + (IntegrationEvent -> Tx.Transaction a) -> + Eff es (Either InboxError (InboxResult a)) +runInboxTransactionWithRetries mMetrics attemptCeiling policy event kafka handler = + runInboxTransactionWithRetriesWith mMetrics attemptCeiling PersistFullEnvelope policy event kafka handler + +-- | Variant of 'runInboxTransactionWithRetries' that controls success-path persistence. +runInboxTransactionWithRetriesWith :: + forall a es. + (IOE :> es, Store :> es) => + Maybe KeiroMetrics -> + Int -> + InboxPersistence -> + InboxDedupePolicy -> + IntegrationEvent -> + Maybe KafkaDeliveryRef -> + (IntegrationEvent -> Tx.Transaction a) -> + Eff es (Either InboxError (InboxResult a)) +runInboxTransactionWithRetriesWith mMetrics attemptCeiling persistence policy event kafka handler = + case dedupeKeyFor policy event kafka of + Left err -> pure (Left err) + Right dedupe -> + Right + <$> runInboxTransactionWithRetriesKeyPersist + mMetrics + attemptCeiling + persistence + (event ^. #source) + dedupe + event + kafka + handler + +-- | Lower-level retrying variant that takes the dedupe key directly. +runInboxTransactionWithRetriesKey :: + forall a es. + (IOE :> es, Store :> es) => + Maybe KeiroMetrics -> + Int -> + Text -> + Text -> + IntegrationEvent -> + Maybe KafkaDeliveryRef -> + (IntegrationEvent -> Tx.Transaction a) -> + Eff es (InboxResult a) +runInboxTransactionWithRetriesKey mMetrics attemptCeiling src dedupe event kafka handler = + runInboxTransactionWithRetriesKeyPersist mMetrics attemptCeiling PersistFullEnvelope src dedupe event kafka handler + +runInboxTransactionWithRetriesKeyPersist :: + forall a es. + (IOE :> es, Store :> es) => + Maybe KeiroMetrics -> + Int -> + InboxPersistence -> + Text -> + Text -> + IntegrationEvent -> + Maybe KafkaDeliveryRef -> + (IntegrationEvent -> Tx.Transaction a) -> + Eff es (InboxResult a) +runInboxTransactionWithRetriesKeyPersist mMetrics attemptCeiling persistence src dedupe event kafka handler = do + now <- liftIO getCurrentTime + attempted <- + trySync $ + runTransaction $ + attemptOneTx persistence (Just attemptCeiling) src dedupe event kafka now handler + result <- case attempted of + Right ok -> pure ok + Left err -> do + failedAt <- liftIO getCurrentTime + let errMsg = Text.pack (displayException err) + attempts <- + runTransaction $ + recordFailedAttemptTx src dedupe event kafka errMsg failedAt + pure (InboxHandlerFailed errMsg attempts) + recordInboxResult mMetrics (Just attemptCeiling) result + pure result + +{- | Process a batch of inbox deliveries with a single transactional fast path. + +The fast path computes each @(source, dedupe_key)@, suppresses repeated +keys within the batch as duplicates, then runs all remaining deliveries +in one Postgres transaction. If any handler throws or condemns that +transaction, the whole batch rolls back and every original delivery is +retried through 'runInboxTransactionWithRetries'. That fallback preserves +per-message failure accounting and prevents one poison message from +discarding unrelated batch mates. + +'Tx.condemn' rolls the transaction back at commit but returns normally, +so it cannot be observed from the transaction's return value alone. +The batch detects it by re-reading one row it should have committed: +every write in the fast path belongs to a delivery classified +'InboxProcessed' (fresh insert as @completed@ or retry promotion to +@completed@), so if the first such row is not @completed@ after the +transaction returns, the whole batch was condemned and the per-message +fallback runs. A batch with no 'InboxProcessed' rows performed no writes, +so a condemned transaction loses nothing. +-} +runInboxTransactionBatch :: + forall a es. + (IOE :> es, Store :> es) => + Maybe KeiroMetrics -> + Int -> + InboxDedupePolicy -> + InboxPersistence -> + [(IntegrationEvent, Maybe KafkaDeliveryRef)] -> + (IntegrationEvent -> Tx.Transaction a) -> + Eff es [Either InboxError (InboxResult a)] +runInboxTransactionBatch mMetrics attemptCeiling policy persistence deliveries handler = do + now <- liftIO getCurrentTime + let plan = planInboxBatch policy deliveries + attempted <- + trySync $ + runTransaction $ + traverse + ( \case + BatchKeyError err -> pure (Left err) + BatchDuplicate -> pure (Right InboxDuplicate) + BatchWork src dedupe event kafka -> + Right <$> attemptOneTx persistence (Just attemptCeiling) src dedupe event kafka now handler + ) + plan + case attempted of + Right results -> do + committed <- verifyBatchCommitted plan results + if committed + then do + for_ results $ \case + Right result -> recordInboxResult mMetrics (Just attemptCeiling) result + Left _ -> pure () + pure results + else perMessageFallback + Left _ -> perMessageFallback + where + perMessageFallback :: Eff es [Either InboxError (InboxResult a)] + perMessageFallback = + traverse + ( \(event, kafka) -> + runInboxTransactionWithRetriesWith mMetrics attemptCeiling persistence policy event kafka handler + ) + deliveries + + -- A condemned transaction returns its results normally but commits + -- nothing. Re-read the first row the batch claims to have completed; + -- if it is not @completed@, the transaction rolled back at commit. + verifyBatchCommitted :: + [BatchPlan] -> + [Either InboxError (InboxResult a)] -> + Eff es Bool + verifyBatchCommitted plan results = + case listToMaybe (mapMaybe processedKey (zip plan results)) of + Nothing -> pure True + Just (src, dedupe) -> do + row <- lookupInbox src dedupe + pure (fmap (^. #status) row == Just InboxCompleted) + + processedKey :: (BatchPlan, Either InboxError (InboxResult a)) -> Maybe (Text, Text) + processedKey = \case + (BatchWork src dedupe _ _, Right (InboxProcessed _)) -> Just (src, dedupe) + _ -> Nothing + +attemptOneTx :: + InboxPersistence -> + Maybe Int -> + Text -> + Text -> + IntegrationEvent -> + Maybe KafkaDeliveryRef -> + UTCTime -> + (IntegrationEvent -> Tx.Transaction a) -> + Tx.Transaction (InboxResult a) +attemptOneTx persistence attemptCeiling src dedupe event kafka now handler = do + inserted <- tryInsertCompletedTx persistence src dedupe event kafka now + case inserted of + Right () -> do + handled <- handler event + pure (InboxProcessed handled) + Left row -> case row ^. #status of + InboxCompleted -> pure InboxDuplicate + InboxProcessing -> pure InboxInProgress + InboxFailed -> case attemptCeiling of + Nothing -> pure (InboxPreviouslyFailed (row ^. #lastError)) + Just attemptLimit + | row ^. #attemptCount >= attemptLimit -> + pure (InboxPreviouslyFailed (row ^. #lastError)) + | otherwise -> do + handled <- handler event + markCompletedTx src dedupe now + pure (InboxProcessed handled) + +recordInboxResult :: (IOE :> es) => Maybe KeiroMetrics -> Maybe Int -> InboxResult a -> Eff es () +recordInboxResult mMetrics attemptCeiling = \case + InboxProcessed _ -> recordInboxProcessed mMetrics 1 + InboxDuplicate -> recordInboxDuplicates mMetrics 1 + InboxPreviouslyFailed _ -> recordInboxFailed mMetrics 1 + InboxHandlerFailed _ attempts -> do + recordInboxFailed mMetrics 1 + case attemptCeiling of + Just attemptLimit | attempts >= attemptLimit -> recordInboxPoisoned mMetrics 1 + _ -> pure () + InboxInProgress -> pure () + +planInboxBatch :: + InboxDedupePolicy -> + [(IntegrationEvent, Maybe KafkaDeliveryRef)] -> + [BatchPlan] +planInboxBatch policy = go Map.empty + where + go _ [] = [] + go seen ((event, kafka) : rest) = + case dedupeKeyFor policy event kafka of + Left err -> BatchKeyError err : go seen rest + Right dedupe -> + let key = (event ^. #source, dedupe) + in if Map.member key seen + then BatchDuplicate : go seen rest + else BatchWork (event ^. #source) dedupe event kafka : go (Map.insert key () seen) rest + +{- | Count the inbox backlog and record the gauge when metrics are enabled. + +The backlog is non-terminal rows: legacy @processing@ rows plus failed rows. +Schedule this on its own interval; it is intentionally not part of the +per-message intake path. +-} +sampleInboxBacklog :: (IOE :> es, Store :> es) => Maybe KeiroMetrics -> Eff es () +sampleInboxBacklog Nothing = pure () +sampleInboxBacklog (Just metrics) = do + backlog <- countInboxBacklog + recordInboxBacklog (Just metrics) (fromIntegral backlog) diff --git a/src/Keiro/Inbox/Kafka.hs b/src/Keiro/Inbox/Kafka.hs new file mode 100644 --- /dev/null +++ b/src/Keiro/Inbox/Kafka.hs @@ -0,0 +1,212 @@ +{- | Reconstruct an 'IntegrationEvent' from Kafka payload bytes plus +headers. + +This module is the receiving-side counterpart of +'Keiro.Outbox.Kafka.integrationEventToKafkaRecord'. It is pure: the +caller supplies the bytes and the @Text@-keyed header map produced by +its Kafka adapter, and gets back a decoded envelope or a typed error. + +@keiro@ itself does not depend on @hw-kafka-client@ or +@shibuya-kafka-adapter@; the consumer adapter in EP-22 bridges the +broker library's header type to @[(Text, Text)]@ before calling +'integrationEventFromKafka'. +-} +module Keiro.Inbox.Kafka ( + KafkaInboundRecord (..), + KafkaDecodeError (..), + integrationEventFromKafka, +) +where + +import Data.Aeson qualified as Aeson +import Data.ByteString (ByteString) +import Data.Maybe (mapMaybe) +import Data.Text qualified as Text +import Data.Text.Encoding qualified as TextEncoding +import Data.Text.Read qualified as TextRead +import Data.Time.Format.ISO8601 (iso8601ParseM) +import Data.UUID qualified as UUID +import Keiro.Inbox.Types (KafkaDeliveryRef (..)) +import Keiro.Integration.Event ( + IntegrationContentType (..), + IntegrationEvent (..), + SchemaReference (..), + TraceContext (..), + headerAttributes, + headerCausationId, + headerContentType, + headerCorrelationId, + headerDestination, + headerEventType, + headerMessageId, + headerOccurredAt, + headerSchemaFingerprint, + headerSchemaId, + headerSchemaRegistry, + headerSchemaSubject, + headerSchemaVersion, + headerSchemaVersionRef, + headerSource, + headerSourceEventId, + headerSourceGlobalPosition, + headerTraceParent, + headerTraceState, + parseContentType, + ) +import Keiro.Prelude +import Kiroku.Store.Types (EventId (..), GlobalPosition (..)) + +{- | A Kafka record as seen by the consumer-side adapter, decoupled from +the broker library's record type. +-} +data KafkaInboundRecord = KafkaInboundRecord + { topic :: !Text + , partition :: !Int64 + , offset :: !Int64 + , key :: !(Maybe Text) + , payload :: !ByteString + , headers :: ![(Text, Text)] + , receivedAt :: !UTCTime + } + deriving stock (Generic, Eq, Show) + +-- | Typed failures from 'integrationEventFromKafka'. +data KafkaDecodeError + = MissingHeader !Text + | InvalidIntHeader !Text !Text + | InvalidUuidHeader !Text !Text + | InvalidTimeHeader !Text !Text + | InvalidJsonHeader !Text !Text + deriving stock (Generic, Eq, Show) + +{- | Reconstruct a full 'IntegrationEvent' plus the 'KafkaDeliveryRef' +recorded for diagnostics. + +The reconstruction is faithful to the canonical header names defined +by 'Keiro.Integration.Event' (e.g. @keiro-message-id@, @keiro-source@, +@traceparent@). Missing required headers (@keiro-source@, +@keiro-destination@, @keiro-event-type@, @keiro-schema-version@, +@content-type@, @keiro-message-id@) produce 'MissingHeader'; malformed +numeric or UUID headers produce 'InvalidIntHeader' / 'InvalidUuidHeader'. +Optional headers are silently absent in the resulting envelope. +-} +integrationEventFromKafka :: + KafkaInboundRecord -> + Either KafkaDecodeError (IntegrationEvent, KafkaDeliveryRef) +integrationEventFromKafka record = do + let hs = record ^. #headers + source <- requireHeader hs headerSource + destination <- requireHeader hs headerDestination + eventType <- requireHeader hs headerEventType + schemaVersionText <- requireHeader hs headerSchemaVersion + schemaVersion <- parseInt headerSchemaVersion schemaVersionText + contentTypeRaw <- requireHeader hs headerContentType + messageId <- requireHeader hs headerMessageId + schemaReference <- buildSchemaReference hs + sourceEventId <- traverseLookup hs headerSourceEventId (fmap EventId . parseUuid headerSourceEventId) + sourceGlobalPosition <- + traverseLookup hs headerSourceGlobalPosition (fmap GlobalPosition . parseInt headerSourceGlobalPosition) + causationId <- traverseLookup hs headerCausationId (fmap EventId . parseUuid headerCausationId) + correlationId <- traverseLookup hs headerCorrelationId (fmap EventId . parseUuid headerCorrelationId) + occurredAt <- fromMaybe (record ^. #receivedAt) <$> traverseLookup hs headerOccurredAt (parseTimeHeader headerOccurredAt) + attributes <- traverseLookup hs headerAttributes (parseJsonHeader headerAttributes) + let traceContext = case Prelude.lookup headerTraceParent hs of + Nothing -> Nothing + Just tp -> Just (TraceContext tp (Prelude.lookup headerTraceState hs)) + event = + IntegrationEvent + { messageId + , source + , destination + , key = record ^. #key + , eventType + , schemaVersion + , contentType = parseContentType contentTypeRaw + , schemaReference + , sourceEventId + , sourceGlobalPosition + , payloadBytes = record ^. #payload + , occurredAt + , causationId + , correlationId + , traceContext + , attributes + } + kafka = + KafkaDeliveryRef + { topic = record ^. #topic + , partition = record ^. #partition + , offset = record ^. #offset + } + pure (event, kafka) + +-- --------------------------------------------------------------------------- +-- Helpers +-- --------------------------------------------------------------------------- + +requireHeader :: [(Text, Text)] -> Text -> Either KafkaDecodeError Text +requireHeader hs name = case Prelude.lookup name hs of + Just v -> Right v + Nothing -> Left (MissingHeader name) + +traverseLookup :: + [(Text, Text)] -> + Text -> + (Text -> Either KafkaDecodeError a) -> + Either KafkaDecodeError (Maybe a) +traverseLookup hs name parser = case Prelude.lookup name hs of + Nothing -> Right Nothing + Just raw -> fmap Just (parser raw) + +parseInt :: (Integral a) => Text -> Text -> Either KafkaDecodeError a +parseInt name raw = case TextRead.signed TextRead.decimal raw of + Right (n, rest) | Text.null rest -> Right n + _ -> Left (InvalidIntHeader name raw) + +parseUuid :: Text -> Text -> Either KafkaDecodeError UUID.UUID +parseUuid name raw = case UUID.fromText raw of + Just u -> Right u + Nothing -> Left (InvalidUuidHeader name raw) + +parseTimeHeader :: Text -> Text -> Either KafkaDecodeError UTCTime +parseTimeHeader name raw = + maybe (Left (InvalidTimeHeader name raw)) Right (iso8601ParseM (Text.unpack raw)) + +parseJsonHeader :: Text -> Text -> Either KafkaDecodeError Value +parseJsonHeader name raw = + case Aeson.eitherDecodeStrict (TextEncoding.encodeUtf8 raw) of + Right value -> Right value + Left _ -> Left (InvalidJsonHeader name raw) + +buildSchemaReference :: + [(Text, Text)] -> + Either KafkaDecodeError (Maybe SchemaReference) +buildSchemaReference hs = do + let registry = Prelude.lookup headerSchemaRegistry hs + subject = Prelude.lookup headerSchemaSubject hs + fingerprint = Prelude.lookup headerSchemaFingerprint hs + versionRef <- traverseLookup hs headerSchemaVersionRef (parseInt headerSchemaVersionRef) + schemaId <- traverseLookup hs headerSchemaId (parseInt headerSchemaId) + let presentFields = + mapMaybe id [registry, subject, fmap (Text.pack . show) versionRef, fmap (Text.pack . show) schemaId, fingerprint] + if null presentFields + then pure Nothing + else + pure + ( Just + ( SchemaReference + { registry + , subject + , version = versionRef + , schemaId + , fingerprint + } + ) + ) + +{- | Silence unused-import warning when 'IntegrationContentType' is +imported only via the open re-export but referenced through +'parseContentType'. +-} +_unusedKeepContentType :: IntegrationContentType -> () +_unusedKeepContentType _ = () diff --git a/src/Keiro/Inbox/Schema.hs b/src/Keiro/Inbox/Schema.hs new file mode 100644 --- /dev/null +++ b/src/Keiro/Inbox/Schema.hs @@ -0,0 +1,613 @@ +{-# LANGUAGE ApplicativeDo #-} + +{- | Hasql-level storage for the idempotent integration-event inbox. + +This module owns the SQL surface that the inbox wrapper +('Keiro.Inbox.runInboxTransaction') and the optional Kafka decoder +('Keiro.Inbox.Kafka') consume. +-} +module Keiro.Inbox.Schema ( + tryInsertCompletedTx, + markCompletedTx, + markFailedTx, + recordFailedAttemptTx, + lookupInbox, + listInbox, + garbageCollectCompleted, + countInboxBacklog, +) +where + +import Contravariant.Extras (contrazip2, contrazip3, contrazip4) +import Data.ByteString (ByteString) +import Data.Functor.Contravariant ((>$<)) +import Data.Time.Clock (NominalDiffTime, addUTCTime) +import Data.Time.Clock.POSIX (posixSecondsToUTCTime) +import Data.UUID (UUID) +import Effectful (Eff, (:>)) +import Hasql.Decoders qualified as D +import Hasql.Encoders qualified as E +import Hasql.Statement (Statement, preparable) +import Keiro.Inbox.Types +import Keiro.Integration.Event ( + IntegrationEvent (..), + SchemaReference (..), + TraceContext (..), + contentTypeText, + parseContentType, + ) +import Keiro.Prelude +import Kiroku.Store.Effect (Store) +import Kiroku.Store.Transaction (runTransaction) +import Kiroku.Store.Types (EventId (..), GlobalPosition (..)) +import "hasql-transaction" Hasql.Transaction qualified as Tx + +{- | Attempt to insert a new completed row. + +Returns 'Left' carrying the existing row if @(source, dedupe_key)@ +already exists; returns 'Right ()' if the insert created a new row. The +caller — typically 'Keiro.Inbox.runInboxTransaction' — then either runs +the handler (new) or branches on the existing row's status (duplicate). + +The row is inserted as @completed@ before the handler runs, but remains +uncommitted until the handler transaction succeeds. On handler failure the +whole transaction rolls back, so the completed row never becomes visible. + +If a concurrent retention job deletes the conflicting row between the +insert attempt and the lookup, this returns 'Right ()'. The handler's effects +then commit without a replacement deduplication row, and a later redelivery +can run the handler again. This preserves at-least-once delivery but not +permanent exactly-once processing. Retention must exceed the maximum tolerated +redelivery delay, and handlers must remain idempotent. +-} +tryInsertCompletedTx :: + InboxPersistence -> + Text -> + Text -> + IntegrationEvent -> + Maybe KafkaDeliveryRef -> + UTCTime -> + Tx.Transaction (Either InboxRow ()) +tryInsertCompletedTx persistence src dedupe event kafka now = do + inserted <- + Tx.statement (toEncodedInsert persistence src dedupe event kafka now) tryInsertStmt + if inserted + then pure (Right ()) + else do + existing <- Tx.statement (src, dedupe) selectByKeyStmt + case existing of + Just row -> pure (Left row) + Nothing -> pure (Right ()) + +-- | Mark an inbox row completed inside the same transaction as the handler. +markCompletedTx :: Text -> Text -> UTCTime -> Tx.Transaction () +markCompletedTx src dedupe now = + Tx.statement (src, dedupe, now) markCompletedStmt + +-- | Mark an inbox row failed inside the same transaction as the handler. +markFailedTx :: Text -> Text -> Text -> UTCTime -> Tx.Transaction () +markFailedTx src dedupe errMsg now = + Tx.statement (src, dedupe, errMsg, now) markFailedStmt + +{- | Record one failed handler attempt for @(source, dedupe_key)@. + +Creates a failed row when the handler transaction rolled back the initial +processing insert, or increments the existing failed row's attempt count. +Returns the new attempt count. +-} +recordFailedAttemptTx :: + Text -> + Text -> + IntegrationEvent -> + Maybe KafkaDeliveryRef -> + Text -> + UTCTime -> + Tx.Transaction Int +recordFailedAttemptTx src dedupe event kafka errMsg now = + Tx.statement (toEncodedFailedInsert src dedupe event kafka errMsg now) recordFailedAttemptStmt + +-- | Read one inbox row. +lookupInbox :: (Store :> es) => Text -> Text -> Eff es (Maybe InboxRow) +lookupInbox src dedupe = + runTransaction $ + Tx.statement (src, dedupe) selectByKeyStmt + +-- | List inbox rows for a source, ordered by @received_at@. Test helper. +listInbox :: (Store :> es) => Text -> Eff es [InboxRow] +listInbox src = + runTransaction $ + Tx.statement src listBySourceStmt + +{- | Count inbox rows in a non-terminal state (backlog gauge source). + +Backlog = rows still @processing@ (in flight) or @failed@ (awaiting a +retry decision). Completed rows are terminal and excluded. +-} +countInboxBacklog :: (Store :> es) => Eff es Int +countInboxBacklog = + runTransaction (Tx.statement () countInboxBacklogStmt) + +{- | Delete completed inbox rows older than @keepFor@ from @now@. + +Returns the number of rows deleted. The retention window defines the +duplicate-detection window: a redelivery that arrives after retention +GC has run will be processed again, so the window must exceed the +maximum delivery delay tolerated by the operator. The user guide +recommends 30 days as a default. See 'tryInsertCompletedTx' for the related +concurrent-GC race and its at-least-once consequence. +-} +garbageCollectCompleted :: + (Store :> es) => + NominalDiffTime -> + UTCTime -> + Eff es Int +garbageCollectCompleted keepFor now = do + let cutoff = addUTCTime (negate keepFor) now + result <- + runTransaction $ + Tx.statement cutoff gcStmt + pure (fromIntegral result) + +-- --------------------------------------------------------------------------- +-- Encoder support +-- --------------------------------------------------------------------------- + +data EncodedInsert = EncodedInsert + { source :: !Text + , dedupeKey :: !Text + , messageId :: !(Maybe Text) + , sourceEventId :: !(Maybe UUID) + , sourceGlobalPosition :: !(Maybe Int64) + , destination :: !(Maybe Text) + , eventType :: !(Maybe Text) + , schemaVersion :: !(Maybe Int64) + , contentType :: !Text + , schemaRegistry :: !(Maybe Text) + , schemaSubject :: !(Maybe Text) + , schemaVersionRef :: !(Maybe Int64) + , schemaId :: !(Maybe Int64) + , schemaFingerprint :: !(Maybe Text) + , causationId :: !(Maybe UUID) + , correlationId :: !(Maybe UUID) + , traceparent :: !(Maybe Text) + , tracestate :: !(Maybe Text) + , kafkaTopic :: !(Maybe Text) + , kafkaPartition :: !(Maybe Int64) + , kafkaOffset :: !(Maybe Int64) + , payloadBytes :: !ByteString + , attributes :: !(Maybe Value) + , occurredAt :: !(Maybe UTCTime) + , receivedAt :: !UTCTime + } + deriving stock (Generic) + +data EncodedFailedInsert = EncodedFailedInsert + { insert :: !EncodedInsert + , lastError :: !Text + } + deriving stock (Generic) + +toEncodedInsert :: + InboxPersistence -> + Text -> + Text -> + IntegrationEvent -> + Maybe KafkaDeliveryRef -> + UTCTime -> + EncodedInsert +toEncodedInsert persistence src dedupe event kafka now = + let mref = event ^. #schemaReference + mtrace = event ^. #traceContext + in EncodedInsert + { source = src + , dedupeKey = dedupe + , messageId = nullIfEmpty (event ^. #messageId) + , sourceEventId = fmap unEventId (event ^. #sourceEventId) + , sourceGlobalPosition = fmap unGlobalPosition (event ^. #sourceGlobalPosition) + , destination = nullIfEmpty (event ^. #destination) + , eventType = nullIfEmpty (event ^. #eventType) + , schemaVersion = persistedSchema (Just (fromIntegral (event ^. #schemaVersion))) + , contentType = contentTypeText (event ^. #contentType) + , schemaRegistry = persistedSchema (mref >>= (^. #registry)) + , schemaSubject = persistedSchema (mref >>= (^. #subject)) + , schemaVersionRef = persistedSchema (fmap fromIntegral (mref >>= (^. #version))) + , schemaId = persistedSchema (mref >>= (^. #schemaId)) + , schemaFingerprint = persistedSchema (mref >>= (^. #fingerprint)) + , causationId = fmap unEventId (event ^. #causationId) + , correlationId = fmap unEventId (event ^. #correlationId) + , traceparent = persistedEnvelope (fmap (^. #traceparent) mtrace) + , tracestate = persistedEnvelope (mtrace >>= (^. #tracestate)) + , kafkaTopic = fmap (^. #topic) kafka + , kafkaPartition = fmap (^. #partition) kafka + , kafkaOffset = fmap (^. #offset) kafka + , payloadBytes = case persistence of + PersistFullEnvelope -> event ^. #payloadBytes + PersistDedupeOnly -> mempty + , attributes = persistedEnvelope (event ^. #attributes) + , occurredAt = Just (event ^. #occurredAt) + , receivedAt = now + } + where + persistedEnvelope :: Maybe x -> Maybe x + persistedEnvelope value = case persistence of + PersistFullEnvelope -> value + PersistDedupeOnly -> Nothing + + persistedSchema :: Maybe x -> Maybe x + persistedSchema = persistedEnvelope + +toEncodedFailedInsert :: + Text -> + Text -> + IntegrationEvent -> + Maybe KafkaDeliveryRef -> + Text -> + UTCTime -> + EncodedFailedInsert +toEncodedFailedInsert src dedupe event kafka errMsg now = + EncodedFailedInsert + { insert = toEncodedInsert PersistFullEnvelope src dedupe event kafka now + , lastError = errMsg + } + +nullIfEmpty :: Text -> Maybe Text +nullIfEmpty t = if t == mempty then Nothing else Just t + +unEventId :: EventId -> UUID +unEventId (EventId u) = u + +unGlobalPosition :: GlobalPosition -> Int64 +unGlobalPosition (GlobalPosition i) = i + +encodedInsertEncoder :: E.Params EncodedInsert +encodedInsertEncoder = + mconcat + [ view #source >$< E.param (E.nonNullable E.text) + , view #dedupeKey >$< E.param (E.nonNullable E.text) + , view #messageId >$< E.param (E.nullable E.text) + , view #sourceEventId >$< E.param (E.nullable E.uuid) + , view #sourceGlobalPosition >$< E.param (E.nullable E.int8) + , view #destination >$< E.param (E.nullable E.text) + , view #eventType >$< E.param (E.nullable E.text) + , view #schemaVersion >$< E.param (E.nullable E.int8) + , view #contentType >$< E.param (E.nonNullable E.text) + , view #schemaRegistry >$< E.param (E.nullable E.text) + , view #schemaSubject >$< E.param (E.nullable E.text) + , view #schemaVersionRef >$< E.param (E.nullable E.int8) + , view #schemaId >$< E.param (E.nullable E.int8) + , view #schemaFingerprint >$< E.param (E.nullable E.text) + , view #causationId >$< E.param (E.nullable E.uuid) + , view #correlationId >$< E.param (E.nullable E.uuid) + , view #traceparent >$< E.param (E.nullable E.text) + , view #tracestate >$< E.param (E.nullable E.text) + , view #kafkaTopic >$< E.param (E.nullable E.text) + , view #kafkaPartition >$< E.param (E.nullable E.int8) + , view #kafkaOffset >$< E.param (E.nullable E.int8) + , view #payloadBytes >$< E.param (E.nonNullable E.bytea) + , view #attributes >$< E.param (E.nullable E.jsonb) + , view #occurredAt >$< E.param (E.nullable E.timestamptz) + , view #receivedAt >$< E.param (E.nonNullable E.timestamptz) + ] + +encodedFailedInsertEncoder :: E.Params EncodedFailedInsert +encodedFailedInsertEncoder = + (view #insert >$< encodedInsertEncoder) + <> (view #lastError >$< E.param (E.nonNullable E.text)) + +-- --------------------------------------------------------------------------- +-- Statements +-- --------------------------------------------------------------------------- + +tryInsertStmt :: Statement EncodedInsert Bool +tryInsertStmt = + preparable + """ + INSERT INTO keiro.keiro_inbox + ( source + , dedupe_key + , message_id + , source_event_id + , source_global_position + , destination + , event_type + , schema_version + , content_type + , schema_registry + , schema_subject + , schema_version_ref + , schema_id + , schema_fingerprint + , causation_id + , correlation_id + , traceparent + , tracestate + , kafka_topic + , kafka_partition + , kafka_offset + , payload_bytes + , attributes + , occurred_at + , received_at + , status + , completed_at + ) + VALUES + ($1, $2, $3, $4, $5, $6, $7, $8, $9, $10, $11, $12, $13, $14, $15, $16, $17, $18, $19, $20, $21, $22, $23, $24, $25, 'completed', $25) + ON CONFLICT (source, dedupe_key) DO NOTHING + RETURNING TRUE + """ + encodedInsertEncoder + (fmap (fromMaybe False) (D.rowMaybe (D.column (D.nonNullable D.bool)))) + +markCompletedStmt :: Statement (Text, Text, UTCTime) () +markCompletedStmt = + preparable + """ + UPDATE keiro.keiro_inbox + SET status = 'completed', + completed_at = $3, + last_error = NULL + WHERE source = $1 AND dedupe_key = $2 + """ + ( contrazip3 + (E.param (E.nonNullable E.text)) + (E.param (E.nonNullable E.text)) + (E.param (E.nonNullable E.timestamptz)) + ) + D.noResult + +markFailedStmt :: Statement (Text, Text, Text, UTCTime) () +markFailedStmt = + preparable + """ + UPDATE keiro.keiro_inbox + SET status = 'failed', + failed_at = $4, + last_error = $3 + WHERE source = $1 AND dedupe_key = $2 + """ + ( contrazip4 + (E.param (E.nonNullable E.text)) + (E.param (E.nonNullable E.text)) + (E.param (E.nonNullable E.text)) + (E.param (E.nonNullable E.timestamptz)) + ) + D.noResult + +recordFailedAttemptStmt :: Statement EncodedFailedInsert Int +recordFailedAttemptStmt = + preparable + """ + INSERT INTO keiro.keiro_inbox + ( source + , dedupe_key + , message_id + , source_event_id + , source_global_position + , destination + , event_type + , schema_version + , content_type + , schema_registry + , schema_subject + , schema_version_ref + , schema_id + , schema_fingerprint + , causation_id + , correlation_id + , traceparent + , tracestate + , kafka_topic + , kafka_partition + , kafka_offset + , payload_bytes + , attributes + , occurred_at + , received_at + , status + , attempt_count + , failed_at + , last_error + ) + VALUES + ($1, $2, $3, $4, $5, $6, $7, $8, $9, $10, $11, $12, $13, $14, $15, $16, $17, $18, $19, $20, $21, $22, $23, $24, $25, 'failed', 1, $25, $26) + ON CONFLICT (source, dedupe_key) DO UPDATE + SET status = 'failed', + attempt_count = keiro_inbox.attempt_count + 1, + last_error = EXCLUDED.last_error, + failed_at = EXCLUDED.failed_at + RETURNING attempt_count + """ + encodedFailedInsertEncoder + (fmap fromIntegral (D.singleRow (D.column (D.nonNullable D.int8)))) + +selectByKeyStmt :: Statement (Text, Text) (Maybe InboxRow) +selectByKeyStmt = + preparable + (selectAllSql <> " WHERE source = $1 AND dedupe_key = $2") + ( contrazip2 + (E.param (E.nonNullable E.text)) + (E.param (E.nonNullable E.text)) + ) + (D.rowMaybe inboxRowDecoder) + +listBySourceStmt :: Statement Text [InboxRow] +listBySourceStmt = + preparable + (selectAllSql <> " WHERE source = $1 ORDER BY received_at, dedupe_key") + (E.param (E.nonNullable E.text)) + (D.rowList inboxRowDecoder) + +countInboxBacklogStmt :: Statement () Int +countInboxBacklogStmt = + preparable + "SELECT COUNT(*)::bigint FROM keiro.keiro_inbox WHERE status IN ('processing', 'failed')" + E.noParams + (fmap fromIntegral (D.singleRow (D.column (D.nonNullable D.int8)))) + +gcStmt :: Statement UTCTime Int64 +gcStmt = + preparable + """ + WITH deleted AS ( + DELETE FROM keiro.keiro_inbox + WHERE status = 'completed' AND completed_at < $1 + RETURNING 1 + ) + SELECT COALESCE(COUNT(*), 0)::bigint FROM deleted + """ + (E.param (E.nonNullable E.timestamptz)) + (D.singleRow (D.column (D.nonNullable D.int8))) + +selectAllSql :: Text +selectAllSql = + """ + SELECT source, dedupe_key, message_id, source_event_id, source_global_position, + destination, event_type, schema_version, content_type, schema_registry, + schema_subject, schema_version_ref, schema_id, schema_fingerprint, + causation_id, correlation_id, traceparent, tracestate, kafka_topic, + kafka_partition, kafka_offset, payload_bytes, attributes, occurred_at, + status, attempt_count, received_at, completed_at, failed_at, last_error + FROM keiro.keiro_inbox + """ + +inboxRowDecoder :: D.Row InboxRow +inboxRowDecoder = fmap assembleInboxRow rawDecoder + +data RawInbox = RawInbox + { source :: !Text + , dedupeKey :: !Text + , messageId :: !(Maybe Text) + , sourceEventId :: !(Maybe EventId) + , sourceGlobalPosition :: !(Maybe GlobalPosition) + , destination :: !(Maybe Text) + , eventType :: !(Maybe Text) + , schemaVersion :: !(Maybe Int) + , contentType :: !Text + , schemaRegistry :: !(Maybe Text) + , schemaSubject :: !(Maybe Text) + , schemaVersionRef :: !(Maybe Int) + , schemaId :: !(Maybe Int64) + , schemaFingerprint :: !(Maybe Text) + , causationId :: !(Maybe EventId) + , correlationId :: !(Maybe EventId) + , traceparent :: !(Maybe Text) + , tracestate :: !(Maybe Text) + , kafkaTopic :: !(Maybe Text) + , kafkaPartition :: !(Maybe Int64) + , kafkaOffset :: !(Maybe Int64) + , payloadBytes :: !ByteString + , attributes :: !(Maybe Value) + , occurredAt :: !(Maybe UTCTime) + , status :: !InboxStatus + , attemptCount :: !Int + , receivedAt :: !UTCTime + , completedAt :: !(Maybe UTCTime) + , failedAt :: !(Maybe UTCTime) + , lastError :: !(Maybe Text) + } + deriving stock (Generic) + +rawDecoder :: D.Row RawInbox +rawDecoder = + RawInbox + <$> D.column (D.nonNullable D.text) + <*> D.column (D.nonNullable D.text) + <*> D.column (D.nullable D.text) + <*> (fmap EventId <$> D.column (D.nullable D.uuid)) + <*> (fmap GlobalPosition <$> D.column (D.nullable D.int8)) + <*> D.column (D.nullable D.text) + <*> D.column (D.nullable D.text) + <*> (fmap fromIntegral <$> D.column (D.nullable D.int8)) + <*> D.column (D.nonNullable D.text) + <*> D.column (D.nullable D.text) + <*> D.column (D.nullable D.text) + <*> (fmap fromIntegral <$> D.column (D.nullable D.int8)) + <*> D.column (D.nullable D.int8) + <*> D.column (D.nullable D.text) + <*> (fmap EventId <$> D.column (D.nullable D.uuid)) + <*> (fmap EventId <$> D.column (D.nullable D.uuid)) + <*> D.column (D.nullable D.text) + <*> D.column (D.nullable D.text) + <*> D.column (D.nullable D.text) + <*> D.column (D.nullable D.int8) + <*> D.column (D.nullable D.int8) + <*> D.column (D.nonNullable D.bytea) + <*> D.column (D.nullable D.jsonb) + <*> D.column (D.nullable D.timestamptz) + <*> D.column (D.nonNullable (D.refine parseInboxStatus D.text)) + <*> (fromIntegral <$> D.column (D.nonNullable D.int8)) + <*> D.column (D.nonNullable D.timestamptz) + <*> D.column (D.nullable D.timestamptz) + <*> D.column (D.nullable D.timestamptz) + <*> D.column (D.nullable D.text) + +assembleInboxRow :: RawInbox -> InboxRow +assembleInboxRow raw = + let traceContext = case raw ^. #traceparent of + Nothing -> Nothing + Just tp -> Just (TraceContext tp (raw ^. #tracestate)) + schemaReference = + case ( raw ^. #schemaRegistry + , raw ^. #schemaSubject + , raw ^. #schemaVersionRef + , raw ^. #schemaId + , raw ^. #schemaFingerprint + ) of + (Nothing, Nothing, Nothing, Nothing, Nothing) -> Nothing + _ -> + Just + ( SchemaReference + (raw ^. #schemaRegistry) + (raw ^. #schemaSubject) + (raw ^. #schemaVersionRef) + (raw ^. #schemaId) + (raw ^. #schemaFingerprint) + ) + kafka = + case (raw ^. #kafkaTopic, raw ^. #kafkaPartition, raw ^. #kafkaOffset) of + (Just t, Just p, Just o) -> Just (KafkaDeliveryRef t p o) + _ -> Nothing + event = + IntegrationEvent + { messageId = fromMaybe mempty (raw ^. #messageId) + , source = raw ^. #source + , destination = fromMaybe mempty (raw ^. #destination) + , key = Nothing + , -- @key@ is not part of the inbox primary key and is not + -- carried separately on the row — the same partition info + -- lives in @kafka@. Receivers that need it can re-derive + -- from the payload. + eventType = fromMaybe mempty (raw ^. #eventType) + , schemaVersion = fromMaybe 0 (raw ^. #schemaVersion) + , contentType = parseContentType (raw ^. #contentType) + , schemaReference + , sourceEventId = raw ^. #sourceEventId + , sourceGlobalPosition = raw ^. #sourceGlobalPosition + , payloadBytes = raw ^. #payloadBytes + , occurredAt = fromMaybe defaultEpoch (raw ^. #occurredAt) + , causationId = raw ^. #causationId + , correlationId = raw ^. #correlationId + , traceContext + , attributes = raw ^. #attributes + } + in InboxRow + { source = raw ^. #source + , dedupeKey = raw ^. #dedupeKey + , event + , kafka + , status = raw ^. #status + , attemptCount = raw ^. #attemptCount + , receivedAt = raw ^. #receivedAt + , completedAt = raw ^. #completedAt + , failedAt = raw ^. #failedAt + , lastError = raw ^. #lastError + } + +{- | Sentinel used when an inbox row was written without an @occurred_at@. + +Inbox rows are observability-shaped; consumers that care should +re-read the timestamp from the envelope payload directly. +-} +defaultEpoch :: UTCTime +defaultEpoch = posixSecondsToUTCTime 0 diff --git a/src/Keiro/Inbox/Types.hs b/src/Keiro/Inbox/Types.hs new file mode 100644 --- /dev/null +++ b/src/Keiro/Inbox/Types.hs @@ -0,0 +1,198 @@ +{- | Shared types for the idempotent integration-event inbox. + +The inbox lives in the consuming bounded context. When a Kafka consumer +receives an integration event, the inbox records a stable external +identity for that message and runs the local handler in the same +transaction. Duplicate redeliveries (Kafka offset retry, rebalance, +producer republish) become observable as duplicates instead of +re-running the handler. +-} +module Keiro.Inbox.Types ( + InboxDedupePolicy (..), + InboxPersistence (..), + InboxStatus (..), + InboxResult (..), + InboxError (..), + InboxRow (..), + KafkaDeliveryRef (..), + inboxStatusText, + parseInboxStatus, + dedupeKeyFor, +) +where + +import Data.Text qualified as Text +import Data.UUID qualified as UUID +import Keiro.Integration.Event (IntegrationEvent) +import Keiro.Prelude +import Kiroku.Store.Types (EventId (..), GlobalPosition (..)) + +{- | Which identity is used as the inbox primary key for an +'IntegrationEvent'. + +* 'PreferIntegrationMessageId' (default) — use the application-level + @messageId@ minted at the producer's outbox enqueue. EP-19 / EP-20 + keep this id stable across publish retries, so it is the natural + primary dedupe key for Kafka-delivered events. +* 'PreferSourceEventIdentity' — use the @sourceEventId@ of the private + event that produced this integration event. Useful when a producer + may emit the same logical fact under different @messageId@s (e.g. + schema-upgrade republish), and the consumer wants those republishes + collapsed to a single handler run. +* 'KafkaDeliveryIdentity' — use the Kafka topic-partition-offset triple + as the dedupe key. Fallback only when neither @messageId@ nor source + identity is available. This identifies one broker delivery, not one + logical producer message: if a producer republishes the same logical + message, Kafka assigns a new offset and this policy will not collapse + the republish. +* 'CustomDedupeKey' — caller supplies the key. Use only when the other + policies cannot represent the identity scheme; the consuming service + owns key collision resistance. +-} +data InboxDedupePolicy + = PreferIntegrationMessageId + | PreferSourceEventIdentity + | KafkaDeliveryIdentity + | CustomDedupeKey !Text + deriving stock (Generic, Eq, Show) + +{- | How much of the integration-event envelope the inbox persists on the +success path. + +The failure path always persists the full envelope because a failed +inbox row is the operator's dead-letter record. +-} +data InboxPersistence + = PersistFullEnvelope + | PersistDedupeOnly + deriving stock (Generic, Eq, Show) + +{- | Lifecycle state of an inbox row. + +* 'InboxProcessing' — legacy on-disk state from older wrappers and + reserved for future async paths. Current single-transaction intake + inserts fresh successful rows directly as 'InboxCompleted'. +* 'InboxCompleted' — handler ran to completion; terminal. +* 'InboxFailed' — handler signaled a permanent failure; terminal. The + caller is responsible for operator action (dead-letter, manual + retry). +-} +data InboxStatus + = InboxProcessing + | InboxCompleted + | InboxFailed + deriving stock (Generic, Eq, Show) + +{- | The classified outcome of 'Keiro.Inbox.runInboxTransaction'. + +* 'InboxProcessed a' — first delivery; handler ran and returned @a@. +* 'InboxDuplicate' — a previous delivery already completed; handler not + run. +* 'InboxInProgress' — a previous attempt is currently in-flight, or a + legacy @processing@ row was read. Current single-transaction intake + does not commit @processing@ rows. Treat as transient. +* 'InboxPreviouslyFailed' — a previous attempt recorded a permanent + failure. Operator should review before reprocessing. +-} +data InboxResult a + = InboxProcessed !a + | InboxDuplicate + | InboxInProgress + | InboxPreviouslyFailed !(Maybe Text) + | InboxHandlerFailed !Text !Int + deriving stock (Generic, Eq, Show) + +{- | Errors surfaced by the inbox wrapper that originate from the inbox +itself rather than from the supplied handler. +-} +data InboxError + = -- | The integration event lacked the field required by the chosen policy. + DedupePolicyUnsatisfied !InboxDedupePolicy + deriving stock (Generic, Eq, Show) + +{- | Optional Kafka-delivery metadata recorded alongside an inbox row. + +Used by 'KafkaDeliveryIdentity' to compute the dedupe key, and stored on +the row regardless of policy so operators can correlate the inbox +record with Kafka logs. Not part of the EP-19 envelope. +-} +data KafkaDeliveryRef = KafkaDeliveryRef + { topic :: !Text + , partition :: !Int64 + , offset :: !Int64 + } + deriving stock (Generic, Eq, Show) + +{- | One row read back from @keiro_inbox@. + +Rows written with 'PersistDedupeOnly' decode with an empty +'IntegrationEvent' @payloadBytes@, no attributes, no trace context, and +no schema reference. Identity, routing, source-event ids, occurrence +time, and Kafka delivery metadata are still preserved. +-} +data InboxRow = InboxRow + { source :: !Text + , dedupeKey :: !Text + , event :: !IntegrationEvent + , kafka :: !(Maybe KafkaDeliveryRef) + , status :: !InboxStatus + , attemptCount :: !Int + , receivedAt :: !UTCTime + , completedAt :: !(Maybe UTCTime) + , failedAt :: !(Maybe UTCTime) + , lastError :: !(Maybe Text) + } + deriving stock (Generic, Eq, Show) + +inboxStatusText :: InboxStatus -> Text +inboxStatusText = \case + InboxProcessing -> "processing" + InboxCompleted -> "completed" + InboxFailed -> "failed" + +parseInboxStatus :: Text -> Either Text InboxStatus +parseInboxStatus = \case + "processing" -> Right InboxProcessing + "completed" -> Right InboxCompleted + "failed" -> Right InboxFailed + other -> Left ("unknown keiro_inbox.status: " <> other) + +{- | Compute the inbox dedupe key for an integration event under the +given policy plus optional Kafka delivery context. Returns 'Left' when +the policy demands a field the envelope does not carry (for example, +'PreferSourceEventIdentity' on an envelope with no +@sourceEventId@). +-} +dedupeKeyFor :: + InboxDedupePolicy -> + IntegrationEvent -> + Maybe KafkaDeliveryRef -> + Either InboxError Text +dedupeKeyFor policy event kafka = case policy of + PreferIntegrationMessageId -> + let mid = event ^. #messageId + in if Text.null mid + then Left (DedupePolicyUnsatisfied policy) + else Right mid + PreferSourceEventIdentity -> + case event ^. #sourceEventId of + Just (EventId u) -> Right (UUID.toText u) + Nothing -> + case event ^. #sourceGlobalPosition of + Just (GlobalPosition p) -> Right (Text.pack (show p)) + Nothing -> Left (DedupePolicyUnsatisfied policy) + KafkaDeliveryIdentity -> + case kafka of + Just ref -> + Right + ( (ref ^. #topic) + <> ":" + <> Text.pack (show (ref ^. #partition)) + <> ":" + <> Text.pack (show (ref ^. #offset)) + ) + Nothing -> Left (DedupePolicyUnsatisfied policy) + CustomDedupeKey k -> + if Text.null k + then Left (DedupePolicyUnsatisfied policy) + else Right k diff --git a/src/Keiro/Outbox.hs b/src/Keiro/Outbox.hs new file mode 100644 --- /dev/null +++ b/src/Keiro/Outbox.hs @@ -0,0 +1,553 @@ +{- | Durable integration-event outbox. + +The outbox decouples "this service has decided to publish an integration +event" from "this service has actually published it". Two surfaces use +it: + +* The canonical 'IntegrationProducer' helper maps durable private events + to public 'Keiro.Integration.Event.IntegrationEvent' values and enqueues + one outbox row per mapped event. It mints @messageId@ as a prefixed + UUIDv7 (TypeID) so the id is time-ordered, human-readable, and stable + across publish retries. +* 'enqueueOutboxTx' is the inline escape hatch for sagas and process + managers that need to emit an integration event without an intermediate + private domain event. It runs inside the caller's + 'Hasql.Transaction.Transaction'. + +The 'publishClaimedOutbox' worker is transport-neutral. It claims rows +with @FOR UPDATE SKIP LOCKED@ plus the configured 'OrderingPolicy', +hands claimed batches to a caller-supplied publish function, and marks rows +sent, retryable, or dead. The Kafka adapter lives in +'Keiro.Outbox.Kafka'. + +Run 'outboxMaintenancePass' on a separate, slower schedule to reclaim rows +left in @publishing@ by crashed workers and to sample the backlog gauge. + +The per-key and per-source ordering policies sort by @created_at@, which +PostgreSQL fills at transaction start. The canonical 'IntegrationProducer' +subscription serializes same-key enqueues, so its ordering is stable. Callers +using the inline 'enqueueIntegrationEventTx' escape hatch concurrently for the +same key must serialize those enqueues themselves or accept best-effort order: +two transactions can commit in the opposite order of their @created_at@ values. +-} +module Keiro.Outbox ( + -- * Re-exports + module Keiro.Outbox.Types, + + -- * Storage primitives (transport-neutral) + enqueueOutboxTx, + claimOutboxBatch, + requeueStuckOutbox, + markOutboxSent, + lookupOutbox, + listOutbox, + countOutboxBacklog, + garbageCollectSent, + + -- * Inline escape hatch + freshOutboxId, + enqueueIntegrationEventTx, + + -- * Canonical producer-subscription helper + IntegrationProducer (..), + IntegrationProducerConfigError (..), + IntegrationEventDraft (..), + mkIntegrationProducer, + mintIntegrationEvent, + draftToEvent, + enqueueProducerEventTx, + + -- * Publisher worker + PublishOutcome (..), + publishClaimedOutbox, + outboxMaintenancePass, + sampleOutboxBacklog, +) +where + +import Data.ByteString (ByteString) +import Data.Map.Strict qualified as Map +import Data.Text qualified as Text +import Data.TypeID qualified as TypeID +import Data.UUID.V7 qualified as V7 +import Effectful (Eff, IOE, (:>)) +import Effectful.Exception (displayException, trySync) +import Keiro.Integration.Event ( + IntegrationContentType, + IntegrationEvent (..), + SchemaReference, + TraceContext, + ) +import Keiro.Outbox.Kafka (outboxRowToKafkaRecord) +import Keiro.Outbox.Schema +import Keiro.Outbox.Types +import Keiro.Prelude +import Keiro.Telemetry ( + KeiroMetrics, + recordOutboxBacklog, + recordOutboxDeadlettered, + recordOutboxPublished, + recordOutboxReclaimed, + recordOutboxRetried, + withProducerSpan, + ) +import Kiroku.Store.Effect (Store) +import Kiroku.Store.Transaction (runTransaction) +import Kiroku.Store.Types (EventId, GlobalPosition, RecordedEvent) +import OpenTelemetry.Attributes.Key (AttributeKey (..), unkey) +import OpenTelemetry.SemanticConventions (error_type) +import OpenTelemetry.Trace.Core (SpanStatus (..), addAttribute, setStatus) +import "hasql-transaction" Hasql.Transaction qualified as Tx + +keiro_outbox_batch_size :: AttributeKey Int64 +keiro_outbox_batch_size = AttributeKey "keiro.outbox.batch.size" + +-- | Mint a fresh time-ordered UUIDv7 for use as an 'OutboxId'. +freshOutboxId :: (IOE :> es) => Eff es OutboxId +freshOutboxId = fmap OutboxId (liftIO V7.genUUID) + +{- | Enqueue an 'IntegrationEvent' from a saga or process manager that is +already running inside a 'runCommandWithSqlEvents' transaction. The +caller supplies a stable 'OutboxId' so retried command attempts coalesce +on the @(source, message_id)@ unique constraint. + +Ordering caveat: under 'PerKeyHeadOfLine' and 'PerSourceStream', the publisher +orders rows by @created_at@, which PostgreSQL sets to transaction-start time. +If two concurrent transactions enqueue the same key/source and commit in the +opposite order, a publisher can observe that order. Serialize same-key enqueues +when strict order matters. +-} +enqueueIntegrationEventTx :: + OutboxId -> + IntegrationEvent -> + Tx.Transaction () +enqueueIntegrationEventTx outboxId event = + enqueueOutboxTx (OutboxMessage{outboxId, event}) + +-- --------------------------------------------------------------------------- +-- Producer-subscription helper +-- --------------------------------------------------------------------------- + +{- | Configuration for the canonical producer subscription. + +A service running 'IntegrationProducer' reads its private event stream, +decodes each event with a 'Keiro.Codec.Codec', calls 'mapEvent', and for +each 'Just' result writes one 'keiro_outbox' row. The helper mints +@messageId@ on each insert so the id is stable across publish retries. + +* 'name' — subscription name used to checkpoint the producer's cursor + in the @subscriptions@ table. +* 'source' — value written into @keiro_outbox.source@; identifies the + producing bounded context. +* 'messageIdPrefix' — TypeID prefix used when minting @messageId@. + Must be 1-63 lowercase Latin letters (e.g. @\"msg\"@, @\"order\"@). + Prefer constructing producers with 'mkIntegrationProducer'; an invalid + prefix passed directly to 'IntegrationProducer' raises when the first + message id is minted. +* 'mapEvent' — pure mapper from a private 'RecordedEvent' and its + decoded payload to an 'IntegrationEventDraft'. Returning 'Nothing' + skips the event without enqueuing a row. +-} +data IntegrationProducer e = IntegrationProducer + { name :: !Text + , source :: !Text + , messageIdPrefix :: !Text + , mapEvent :: !(RecordedEvent -> e -> Maybe IntegrationEventDraft) + } + deriving stock (Generic) + +data IntegrationProducerConfigError + = InvalidMessageIdPrefix !Text !Text + deriving stock (Generic, Eq, Show) + +-- | Validate an integration producer before starting its subscription. +mkIntegrationProducer :: IntegrationProducer e -> Either IntegrationProducerConfigError (IntegrationProducer e) +mkIntegrationProducer producer = + case TypeID.checkPrefix (producer ^. #messageIdPrefix) of + Nothing -> Right producer + Just err -> + Left + ( InvalidMessageIdPrefix + (producer ^. #messageIdPrefix) + (Text.pack (show err)) + ) + +{- | Everything in 'IntegrationEvent' except 'messageId' and 'source' — +those are filled in by 'mintIntegrationEvent' from the producer +configuration and the freshly minted TypeID. + +@sourceEventId@ and @sourceGlobalPosition@ default to the values on the +underlying 'RecordedEvent' (see 'mintIntegrationEvent'); a mapper that +needs to override them can replace the draft fields directly. +-} +data IntegrationEventDraft = IntegrationEventDraft + { destination :: !Text + , key :: !(Maybe Text) + , eventType :: !Text + , schemaVersion :: !Int + , contentType :: !IntegrationContentType + , schemaReference :: !(Maybe SchemaReference) + , sourceEventId :: !(Maybe EventId) + , sourceGlobalPosition :: !(Maybe GlobalPosition) + , payloadBytes :: !ByteString + , occurredAt :: !UTCTime + , causationId :: !(Maybe EventId) + , correlationId :: !(Maybe EventId) + , traceContext :: !(Maybe TraceContext) + , attributes :: !(Maybe Value) + } + deriving stock (Generic, Eq, Show) + +{- | Mint a fresh @messageId@ (TypeID with the producer's prefix) and build +the full 'IntegrationEvent' from the draft. Lives in 'IO' because TypeID +generation reads the global UUIDv7 sequence counter. +-} +mintIntegrationEvent :: + (IOE :> es) => + IntegrationProducer e -> + IntegrationEventDraft -> + Eff es IntegrationEvent +mintIntegrationEvent producer draft = do + typeId <- liftIO (TypeID.genTypeID (producer ^. #messageIdPrefix)) + pure (draftToEvent (producer ^. #source) (TypeID.toText typeId) draft) + +-- | Build an 'IntegrationEvent' from a source, a minted message id, and a draft. +draftToEvent :: Text -> Text -> IntegrationEventDraft -> IntegrationEvent +draftToEvent source minted draft = + IntegrationEvent + { messageId = minted + , source + , destination = draft ^. #destination + , key = draft ^. #key + , eventType = draft ^. #eventType + , schemaVersion = draft ^. #schemaVersion + , contentType = draft ^. #contentType + , schemaReference = draft ^. #schemaReference + , sourceEventId = draft ^. #sourceEventId + , sourceGlobalPosition = draft ^. #sourceGlobalPosition + , payloadBytes = draft ^. #payloadBytes + , occurredAt = draft ^. #occurredAt + , causationId = draft ^. #causationId + , correlationId = draft ^. #correlationId + , traceContext = draft ^. #traceContext + , attributes = draft ^. #attributes + } + +{- | Enqueue one drafted producer event inside an existing transaction. + +This is the primitive a subscription worker calls per event. It mints a +fresh @messageId@ (TypeID), constructs the full envelope, and inserts +the row. The caller supplies the 'OutboxId' so retries from a known +subscription cursor coalesce on @(source, message_id)@. + +The TypeID is minted before the insert; if the transaction rolls back +the message id is discarded (no observable effect) and the next attempt +mints a different id. Idempotency at the row level relies on a stable +'OutboxId', not the minted message id. + +Ordering caveat: @created_at@ records transaction-start time. Under +'PerKeyHeadOfLine' or 'PerSourceStream', concurrent transactions for the same +key/source can commit in the opposite order and are therefore best-effort +unless the caller serializes them. The canonical producer subscription does +serialize same-key enqueues. +-} +enqueueProducerEventTx :: + forall e es. + (IOE :> es) => + IntegrationProducer e -> + OutboxId -> + IntegrationEventDraft -> + Eff es (Tx.Transaction ()) +enqueueProducerEventTx producer outboxId draft = do + event <- mintIntegrationEvent producer draft + pure (enqueueOutboxTx (OutboxMessage{outboxId, event})) + +-- --------------------------------------------------------------------------- +-- Publisher worker +-- --------------------------------------------------------------------------- + +-- | Result of one publish attempt as reported by the transport-specific publisher. +data PublishOutcome + = -- | Kafka acknowledged the publish. + PublishSucceeded + | -- | Publish failed; will be retried after the configured backoff. + PublishFailed !Text + deriving stock (Generic, Eq, Show) + +{- | Drain claimed outbox rows by handing the claimed batch to @publish@ and +reflecting the outcomes back into row statuses. + +Claims rows in batches of @batchSize@ under the active 'OrderingPolicy', +calls @publish@ with the claimed rows in claim order, and marks every row +sent or — using 'markOutboxFailedTx' — failed/dead. The publish result must +contain one outcome per input row; a missing outcome is treated as +@PublishFailed "publisher returned no outcome"@. If the publisher throws, +every row in that call is treated as failed with the exception text. + +For ordered policies, if a row fails then later rows in the same ordered group +are skipped and returned to @failed@ without consuming an attempt; these +skipped rows count as 'OutboxPublishSummary.retried'. A real Kafka transport +must not successfully deliver a later same-key record after reporting an +earlier same-key failure from the same call. On 'StopTheLine', the worker calls +@publish@ with singleton batches and halts after the first failed row, recording +the offending 'OutboxId' in 'haltedOn'. + +Returns when one of: + +* No rows are claimable. +* The active policy is 'StopTheLine' and a publish failed. + +The worker does not loop indefinitely; the application is expected to +schedule it repeatedly (e.g. once per process-compose tick). +-} +publishClaimedOutbox :: + forall es. + (IOE :> es, Store :> es) => + ([OutboxRow] -> Eff es [(OutboxId, PublishOutcome)]) -> + OutboxPublishOptions -> + Maybe KeiroMetrics -> + Eff es OutboxPublishSummary +publishClaimedOutbox publish options mMetrics = do + now <- liftIO getCurrentTime + rows <- claimOutboxBatch (options ^. #orderingPolicy) (options ^. #batchSize) now + summary <- publishBatch rows + -- Counters from the aggregated pass summary (each a no-op under 'Nothing'; + -- a zero delta is harmless). + recordOutboxPublished mMetrics (fromIntegral (summary ^. #published)) + recordOutboxRetried mMetrics (fromIntegral (summary ^. #retried)) + recordOutboxDeadlettered mMetrics (fromIntegral (summary ^. #dead)) + pure summary + where + publishBatch :: [OutboxRow] -> Eff es OutboxPublishSummary + publishBatch [] = + pure OutboxPublishSummary{claimed = 0, published = 0, retried = 0, dead = 0, haltedOn = Nothing} + publishBatch batch = + case options ^. #orderingPolicy of + StopTheLine -> publishStopTheLine batch batch [] Nothing + policy -> do + outcomes <- publishRows batch + markProcessedOutcomes policy batch outcomes Nothing + + publishStopTheLine :: + [OutboxRow] -> + [OutboxRow] -> + [(OutboxId, PublishOutcome)] -> + Maybe OutboxId -> + Eff es OutboxPublishSummary + publishStopTheLine original [] outcomes halted = + markProcessedOutcomes StopTheLine original (Map.fromList outcomes) halted + publishStopTheLine original (row : rest) outcomes _ = do + result <- publishRows [row] + let outcome = outcomeFor result row + outcomes' = outcomes <> [(row ^. #outboxId, outcome)] + case outcome of + PublishSucceeded -> publishStopTheLine original rest outcomes' Nothing + PublishFailed _ -> markProcessedOutcomes StopTheLine original (Map.fromList outcomes') (Just (row ^. #outboxId)) + + publishRows :: [OutboxRow] -> Eff es (Map.Map OutboxId PublishOutcome) + publishRows [] = pure Map.empty + publishRows batch@(firstRow : _) = + Map.fromList + <$> withBatchSpan + batch + firstRow + ( do + attempted <- trySync (publish batch) + let normalized = + case attempted of + Left err -> + let errMsg = Text.pack (displayException err) + in [(row ^. #outboxId, PublishFailed errMsg) | row <- batch] + Right reported -> + normalizeOutcomes batch reported + pure normalized + ) + + withBatchSpan :: + [OutboxRow] -> + OutboxRow -> + Eff es [(OutboxId, PublishOutcome)] -> + Eff es [(OutboxId, PublishOutcome)] + withBatchSpan batch firstRow action = + withProducerSpan + (options ^. #tracer) + (firstRow ^. #event) + (outboxRowToKafkaRecord firstRow) + $ \mSpan -> do + for_ mSpan $ \sp -> + addAttribute sp (unkey keiro_outbox_batch_size) (fromIntegral (length batch) :: Int64) + outcomes <- action + case (mSpan, firstFailure outcomes) of + (Just sp, Just errMsg) -> do + addAttribute sp (unkey error_type) ("publish_failed" :: Text) + setStatus sp (Error errMsg) + _ -> pure () + pure outcomes + + normalizeOutcomes :: [OutboxRow] -> [(OutboxId, PublishOutcome)] -> [(OutboxId, PublishOutcome)] + normalizeOutcomes batch reported = + let reportedMap = Map.fromList reported + in [ (row ^. #outboxId, outcomeFor reportedMap row) + | row <- batch + ] + + outcomeFor :: Map.Map OutboxId PublishOutcome -> OutboxRow -> PublishOutcome + outcomeFor outcomes row = + fromMaybe (PublishFailed "publisher returned no outcome") $ + Map.lookup (row ^. #outboxId) outcomes + + firstFailure :: [(OutboxId, PublishOutcome)] -> Maybe Text + firstFailure [] = Nothing + firstFailure ((_, PublishSucceeded) : rest) = firstFailure rest + firstFailure ((_, PublishFailed errMsg) : _) = Just errMsg + + markProcessedOutcomes :: + OrderingPolicy -> + [OutboxRow] -> + Map.Map OutboxId PublishOutcome -> + Maybe OutboxId -> + Eff es OutboxPublishSummary + markProcessedOutcomes policy batch outcomes halted = do + now <- liftIO getCurrentTime + let marks = foldMap (groupMarks outcomes) (outcomeGroups policy batch) + sentIds = marks ^. #sentIds + failedRows = marks ^. #failedRows + skippedRows = marks ^. #skippedRows + failedStatuses <- + if null failedRows && null skippedRows + then pure [] + else runTransaction $ do + statuses <- traverse (markFailed now) failedRows + traverse_ (markSkipped now) skippedRows + pure statuses + _ <- markOutboxSentBatch sentIds now + let deadCount = length [() | OutboxDead <- failedStatuses] + retriedFailures = length failedStatuses - deadCount + pure + OutboxPublishSummary + { claimed = length batch + , published = length sentIds + , retried = retriedFailures + length skippedRows + , dead = deadCount + , haltedOn = halted + } + + markFailed :: UTCTime -> (OutboxRow, Text) -> Tx.Transaction OutboxStatus + markFailed now (row, errMsg) = + markOutboxFailedTx + (row ^. #outboxId) + errMsg + (options ^. #maxAttempts) + (nextDelay (options ^. #backoff) (row ^. #attemptCount)) + now + + markSkipped :: UTCTime -> OutboxRow -> Tx.Transaction () + markSkipped now row = + markOutboxSkippedTx + (row ^. #outboxId) + "skipped: earlier record for the same key failed" + now + +{- | Reclaim crashed publisher rows and record the outbox backlog gauge. + +Schedule this pass independently from 'publishClaimedOutbox', typically on a +slower timer. It is the only library worker path that reclaims rows stranded in +@publishing@. +-} +outboxMaintenancePass :: + (IOE :> es, Store :> es) => + OutboxMaintenanceOptions -> + Maybe KeiroMetrics -> + Eff es OutboxMaintenanceSummary +outboxMaintenancePass options mMetrics = do + now <- liftIO getCurrentTime + (requeued, deadLettered) <- + requeueStuckOutbox + (options ^. #maxAttempts) + (options ^. #publishingTimeout) + now + recordOutboxReclaimed mMetrics (fromIntegral requeued) + recordOutboxDeadlettered mMetrics (fromIntegral deadLettered) + backlog <- countOutboxBacklog + recordOutboxBacklog mMetrics (fromIntegral backlog) + pure OutboxMaintenanceSummary{requeued, deadLettered, backlog} + +-- | Count publishable rows and record the outbox backlog gauge when metrics are enabled. +sampleOutboxBacklog :: (IOE :> es, Store :> es) => Maybe KeiroMetrics -> Eff es () +sampleOutboxBacklog Nothing = pure () +sampleOutboxBacklog (Just metrics) = do + backlog <- countOutboxBacklog + recordOutboxBacklog (Just metrics) (fromIntegral backlog) + +data OutcomeMarks = OutcomeMarks + { sentIds :: ![OutboxId] + , failedRows :: ![(OutboxRow, Text)] + , skippedRows :: ![OutboxRow] + } + deriving stock (Generic) + +instance Semigroup OutcomeMarks where + left <> right = + OutcomeMarks + { sentIds = (left ^. #sentIds) <> (right ^. #sentIds) + , failedRows = (left ^. #failedRows) <> (right ^. #failedRows) + , skippedRows = (left ^. #skippedRows) <> (right ^. #skippedRows) + } + +instance Monoid OutcomeMarks where + mempty = OutcomeMarks{sentIds = [], failedRows = [], skippedRows = []} + +groupMarks :: Map.Map OutboxId PublishOutcome -> [OutboxRow] -> OutcomeMarks +groupMarks outcomes = go [] + where + go sent [] = mempty{sentIds = sent} + go sent (row : rest) = + case fromMaybe (PublishFailed "publisher returned no outcome") (Map.lookup (row ^. #outboxId) outcomes) of + PublishSucceeded -> go (sent <> [row ^. #outboxId]) rest + PublishFailed errMsg -> + OutcomeMarks + { sentIds = sent + , failedRows = [(row, errMsg)] + , skippedRows = rest + } + +data OutcomeGroupKey + = BatchGroup + | SourceGroup !Text + | RowGroup !OutboxId + | KeyGroup !Text !Text + deriving stock (Generic, Eq) + +data OutcomeGroup = OutcomeGroup + { groupKey :: !OutcomeGroupKey + , groupRows :: ![OutboxRow] + } + deriving stock (Generic) + +outcomeGroups :: OrderingPolicy -> [OutboxRow] -> [[OutboxRow]] +outcomeGroups policy = + fmap (^. #groupRows) . foldl' addGroup [] + where + addGroup groups row = + appendGroup (keyFor row) row groups + keyFor row = + case policy of + -- A claimed batch can hold runs from several independent sources; + -- a failure in one source's run must not skip another source's rows. + PerSourceStream -> SourceGroup (row ^. #event . #source) + -- Deliberately one group: any failure halts the worker, and the + -- entire remaining batch is skipped without consuming attempts. + StopTheLine -> BatchGroup + BestEffort -> RowGroup (row ^. #outboxId) + _ -> + case row ^. #event . #key of + Nothing -> RowGroup (row ^. #outboxId) + Just key -> KeyGroup (row ^. #event . #source) key + +appendGroup :: OutcomeGroupKey -> OutboxRow -> [OutcomeGroup] -> [OutcomeGroup] +appendGroup key row [] = [OutcomeGroup{groupKey = key, groupRows = [row]}] +appendGroup key row (group : rest) + | group ^. #groupKey == key = + (group & #groupRows %~ (<> [row])) : rest + | otherwise = + group : appendGroup key row rest diff --git a/src/Keiro/Outbox/Kafka.hs b/src/Keiro/Outbox/Kafka.hs new file mode 100644 --- /dev/null +++ b/src/Keiro/Outbox/Kafka.hs @@ -0,0 +1,70 @@ +{- | Transport-neutral Kafka representation for outbox rows. + +This module owns the conversion from 'Keiro.Outbox.Types.OutboxRow' to a +neutral 'KafkaProducerRecord' value. It deliberately does not import +@hw-kafka-client@ or @kafka-effectful@: keiro itself remains free of +librdkafka system-library requirements. The integration test package +(EP-22) bridges 'KafkaProducerRecord' to +@Kafka.Producer.Types.ProducerRecord@ from @hw-kafka-client@ inside its +own dependency scope. + +A 'KafkaProducerRecord' carries everything the broker layer needs: +topic, optional partition key, the raw payload bytes from the EP-19 +envelope, and the canonical header set. Building the record is pure; +publishing is the caller's responsibility. + +The outbox worker opens one producer span around each claimed publish batch. +Adapters that need per-record broker visibility should add their own spans +around the actual Kafka produce calls. +-} +module Keiro.Outbox.Kafka ( + KafkaProducerRecord (..), + outboxRowToKafkaRecord, + integrationEventToKafkaRecord, +) +where + +import Data.ByteString (ByteString) +import Data.Text.Encoding qualified as TE +import Keiro.Integration.Event (IntegrationEvent, integrationHeaders, integrationPayload) +import Keiro.Outbox.Types (OutboxRow (..)) +import Keiro.Prelude + +{- | A neutral Kafka producer record. + +Fields: + +* 'topic' — Kafka topic, taken from 'IntegrationEvent.destination'. +* 'key' — partition key bytes (UTF-8 encoded). 'Nothing' means + Kafka round-robins the record across partitions and skips per-key + ordering. +* 'payload' — exactly the bytes from + 'Keiro.Integration.Event.integrationPayload'. +* 'headers' — UTF-8 encoded view of + 'Keiro.Integration.Event.integrationHeaders'. + +The byte encoding for keys and headers is UTF-8 by convention; Kafka +treats both as opaque bytes, so a future binary-key transport can drop +the encoding by populating 'key' directly. +-} +data KafkaProducerRecord = KafkaProducerRecord + { topic :: !Text + , key :: !(Maybe ByteString) + , payload :: !ByteString + , headers :: ![(ByteString, ByteString)] + } + deriving stock (Generic, Eq, Show) + +-- | Build a 'KafkaProducerRecord' from a published outbox row. +outboxRowToKafkaRecord :: OutboxRow -> KafkaProducerRecord +outboxRowToKafkaRecord row = integrationEventToKafkaRecord (row ^. #event) + +-- | Build a 'KafkaProducerRecord' directly from an 'IntegrationEvent'. +integrationEventToKafkaRecord :: IntegrationEvent -> KafkaProducerRecord +integrationEventToKafkaRecord event = + KafkaProducerRecord + { topic = event ^. #destination + , key = fmap TE.encodeUtf8 (event ^. #key) + , payload = integrationPayload event + , headers = [(TE.encodeUtf8 n, TE.encodeUtf8 v) | (n, v) <- integrationHeaders event] + } diff --git a/src/Keiro/Outbox/Schema.hs b/src/Keiro/Outbox/Schema.hs new file mode 100644 --- /dev/null +++ b/src/Keiro/Outbox/Schema.hs @@ -0,0 +1,811 @@ +{-# LANGUAGE ApplicativeDo #-} + +{- | Hasql-level storage for the durable integration-event outbox. + +This module owns the SQL surface that publishers call into. Higher-level +helpers ('Keiro.Outbox') and transport adapters +('Keiro.Outbox.Kafka') consume these primitives. +-} +module Keiro.Outbox.Schema ( + enqueueOutboxTx, + claimOutboxBatch, + requeueStuckOutbox, + markOutboxSent, + markOutboxSentBatch, + markOutboxFailedTx, + markOutboxSkippedTx, + lookupOutbox, + listOutbox, + countOutboxBacklog, + garbageCollectSent, +) +where + +import Contravariant.Extras (contrazip2, contrazip3, contrazip5) +import Data.ByteString (ByteString) +import Data.Functor.Contravariant ((>$<)) +import Data.Time.Clock (NominalDiffTime, addUTCTime) +import Data.UUID (UUID) +import Effectful (Eff, (:>)) +import Hasql.Decoders qualified as D +import Hasql.Encoders qualified as E +import Hasql.Statement (Statement, preparable) +import Keiro.Integration.Event ( + IntegrationEvent (..), + SchemaReference (..), + TraceContext (..), + contentTypeText, + parseContentType, + ) +import Keiro.Outbox.Types +import Keiro.Prelude +import Kiroku.Store.Effect (Store) +import Kiroku.Store.Transaction (runTransaction) +import Kiroku.Store.Types (EventId (..), GlobalPosition (..)) +import "hasql-transaction" Hasql.Transaction qualified as Tx + +{- | Enqueue one integration event inside an existing transaction. + +The @(source, message_id)@ unique constraint catches duplicate retries +from a saga/process-manager. Callers that mint a fresh @messageId@ per +attempt should also mint a fresh @outboxId@; callers that want +idempotent retries should reuse both. + +The row's @created_at@ value is the PostgreSQL transaction-start time. The +per-key and per-source publisher policies therefore provide only best-effort +ordering when concurrent transactions enqueue the same key/source and commit +in the opposite order. Serialize those transactions when strict order matters; +the canonical producer subscription already does so. +-} +enqueueOutboxTx :: OutboxMessage -> Tx.Transaction () +enqueueOutboxTx message = + Tx.statement (toEncodedRow message) enqueueOutboxStmt + +-- | Read a single outbox row by id. Used by tests and inspection tooling. +lookupOutbox :: (Store :> es) => OutboxId -> Eff es (Maybe OutboxRow) +lookupOutbox outboxId = + runTransaction $ + Tx.statement (unOutboxId outboxId) lookupOutboxStmt + +{- | List outbox rows for a source, ordered by @created_at@. Used by tests; +not intended for application traffic. +-} +listOutbox :: (Store :> es) => Text -> Eff es [OutboxRow] +listOutbox source = + runTransaction $ + Tx.statement source listOutboxStmt + +{- | Count outbox rows awaiting publish (backlog gauge source). + +Backlog = rows in a claimable, non-terminal state. Mirrors the claim +query's @status IN ('pending','failed')@ predicate so the gauge measures +exactly the rows a publisher still has to drain (rows held mid-pass in +@publishing@, and the terminal @sent@/@dead@ rows, are excluded). +-} +countOutboxBacklog :: (Store :> es) => Eff es Int +countOutboxBacklog = + runTransaction (Tx.statement () countBacklogStmt) + +{- | Delete @sent@ rows whose @published_at@ is older than @keepFor@ before +@now@. + +Returns the number of rows deleted. @dead@ rows are never deleted: they are +operator action items proving an event was not published. The retention window +only bounds how long successful publish history remains queryable; consumer +dedupe lives in the inbox, not here. +-} +garbageCollectSent :: + (Store :> es) => + NominalDiffTime -> + UTCTime -> + Eff es Int +garbageCollectSent keepFor now = do + let cutoff = addUTCTime (negate keepFor) now + result <- + runTransaction $ + Tx.statement cutoff gcSentStmt + pure (fromIntegral result) + +{- | Claim up to @limit@ rows ready for publish. + +Rows in @pending@ or @failed@ status whose @next_attempt_at@ has passed +become candidates. The selection is filtered by 'OrderingPolicy': + +* 'PerKeyHeadOfLine' — a row is claimed only if every earlier + non-terminal row with the same @(source, message_key)@ is also claimed + by the same statement. Rows with @message_key IS NULL@ bypass the + per-key check. +* 'PerSourceStream' — a row is claimed only if every earlier + non-terminal row in the same @source@ is also claimed by the same + statement, regardless of key. +* 'StopTheLine' — same as 'PerKeyHeadOfLine' at claim time; the worker + halts on the first failure (decided at the worker level). +* 'BestEffort' — no head-of-line predicate. + +The returned list preserves @(created_at, outbox_id)@ order. Per-key and +per-source subsequences are therefore gapless ordered runs. The @LIMIT@ +applies to the locked candidate set before the post-filter; under +concurrent claimers or a limit cut through the middle of a run, a pass +can return fewer than @limit@ rows even when more rows are ready. + +Claimed rows are transitioned to @publishing@ and have their +@attempt_count@ incremented atomically. +-} +claimOutboxBatch :: + (Store :> es) => + OrderingPolicy -> + Int -> + UTCTime -> + Eff es [OutboxRow] +claimOutboxBatch policy limit now = + runTransaction $ + Tx.statement (fromIntegral limit, now) (claimStmt policy) + +{- | Reclaim rows stranded in @publishing@ longer than @olderThan@. + +Rows whose claim already consumed the attempt budget are dead-lettered; the +rest return to @failed@ so the regular claim query can retry them. Returns +@(requeued, deadLettered)@. +-} +requeueStuckOutbox :: + (Store :> es) => + Int -> + NominalDiffTime -> + UTCTime -> + Eff es (Int, Int) +requeueStuckOutbox maxAttempts olderThan now = + runTransaction $ do + let cutoff = addUTCTime (negate olderThan) now + dead <- Tx.statement (cutoff, fromIntegral maxAttempts, now) deadLetterStuckStmt + requeued <- Tx.statement (cutoff, fromIntegral maxAttempts, now) requeueStuckStmt + pure (fromIntegral requeued, fromIntegral dead) + +{- | Mark a row as successfully published. Sets @published_at@ and clears +@last_error@. Returns 'False' if the row left @publishing@ before the mark, +for example because a stale-row sweeper or operator changed it while the +transport publish was in flight. The publish may still have happened; callers +must treat this as at-least-once delivery. +-} +markOutboxSent :: (Store :> es) => OutboxId -> UTCTime -> Eff es Bool +markOutboxSent outboxId now = + runTransaction $ + Tx.statement (unOutboxId outboxId, now) markSentStmt + +{- | Mark many rows as successfully published in one statement. + +Only rows still in @publishing@ transition. Returns how many rows changed; +callers treat a shortfall as benign because delivery is already at-least-once. +-} +markOutboxSentBatch :: (Store :> es) => [OutboxId] -> UTCTime -> Eff es Int +markOutboxSentBatch [] _ = pure 0 +markOutboxSentBatch outboxIds now = + fromIntegral + <$> runTransaction + ( Tx.statement + (fmap unOutboxId outboxIds, now) + markSentBatchStmt + ) + +{- | Mark a row as failed and decide whether it is retryable or dead. + +Reads the current @attempt_count@; if it is greater than or equal to +@maxAttempts@, transitions to 'OutboxDead'. Otherwise transitions to +'OutboxFailed' and sets @next_attempt_at = now + delay@. Returns the +resulting status so the worker can update its summary counters. + +Runs inside the caller's transaction to keep "read attempt count → write +status" atomic with respect to other workers. + +Only rows still in @publishing@ are updated (matching 'markSentBatchStmt' +and 'markSkippedStmt'): if the row outlived 'publishingTimeout' and +'outboxMaintenancePass' already requeued it — possibly handing it to +another worker — a late failure mark from the original worker must not +flip the re-claimed row mid-publish. +-} +markOutboxFailedTx :: + OutboxId -> + Text -> + Int -> + NominalDiffTime -> + UTCTime -> + Tx.Transaction OutboxStatus +markOutboxFailedTx outboxId errMsg maxAttempts delay now = do + currentAttempt <- Tx.statement (unOutboxId outboxId) readAttemptCountStmt + let attempt = fromMaybe 0 currentAttempt + shouldDie = attempt >= maxAttempts + nextStatus = if shouldDie then OutboxDead else OutboxFailed + nextAttempt = addUTCTime delay now + Tx.statement + (unOutboxId outboxId, statusText nextStatus, errMsg, nextAttempt, now) + markFailedStmt + pure nextStatus + +{- | Return a claimed row to @failed@ without consuming an attempt. + +Used for rows skipped because an earlier row in the same ordered group failed +inside the same publish batch. +-} +markOutboxSkippedTx :: OutboxId -> Text -> UTCTime -> Tx.Transaction () +markOutboxSkippedTx outboxId errMsg now = + Tx.statement (unOutboxId outboxId, errMsg, now) markSkippedStmt + +-- --------------------------------------------------------------------------- +-- Encoder support +-- --------------------------------------------------------------------------- + +{- | Flattened row used as the encoder input. Field order is locked to +the INSERT statement; the encoder threads each field through a separate +'E.Params' fragment joined by 'mconcat'. +-} +data EncodedRow = EncodedRow + { outboxId :: !UUID + , messageId :: !Text + , source :: !Text + , destination :: !Text + , messageKey :: !(Maybe Text) + , eventType :: !Text + , schemaVersion :: !Int64 + , contentType :: !Text + , schemaRegistry :: !(Maybe Text) + , schemaSubject :: !(Maybe Text) + , schemaVersionRef :: !(Maybe Int64) + , schemaId :: !(Maybe Int64) + , schemaFingerprint :: !(Maybe Text) + , sourceEventId :: !(Maybe UUID) + , sourceGlobalPosition :: !(Maybe Int64) + , causationId :: !(Maybe UUID) + , correlationId :: !(Maybe UUID) + , traceparent :: !(Maybe Text) + , tracestate :: !(Maybe Text) + , payloadBytes :: !ByteString + , attributes :: !(Maybe Value) + , occurredAt :: !UTCTime + } + deriving stock (Generic) + +toEncodedRow :: OutboxMessage -> EncodedRow +toEncodedRow message = + let event = message ^. #event + mref = event ^. #schemaReference + mtrace = event ^. #traceContext + in EncodedRow + { outboxId = unOutboxId (message ^. #outboxId) + , messageId = event ^. #messageId + , source = event ^. #source + , destination = event ^. #destination + , messageKey = event ^. #key + , eventType = event ^. #eventType + , schemaVersion = fromIntegral (event ^. #schemaVersion) + , contentType = contentTypeText (event ^. #contentType) + , schemaRegistry = mref >>= (^. #registry) + , schemaSubject = mref >>= (^. #subject) + , schemaVersionRef = fmap fromIntegral (mref >>= (^. #version)) + , schemaId = mref >>= (^. #schemaId) + , schemaFingerprint = mref >>= (^. #fingerprint) + , sourceEventId = fmap unEventId (event ^. #sourceEventId) + , sourceGlobalPosition = fmap unGlobalPosition (event ^. #sourceGlobalPosition) + , causationId = fmap unEventId (event ^. #causationId) + , correlationId = fmap unEventId (event ^. #correlationId) + , traceparent = fmap (^. #traceparent) mtrace + , tracestate = mtrace >>= (^. #tracestate) + , payloadBytes = event ^. #payloadBytes + , attributes = event ^. #attributes + , occurredAt = event ^. #occurredAt + } + +unEventId :: EventId -> UUID +unEventId (EventId u) = u + +unGlobalPosition :: GlobalPosition -> Int64 +unGlobalPosition (GlobalPosition i) = i + +encodedRowEncoder :: E.Params EncodedRow +encodedRowEncoder = + mconcat + [ view #outboxId >$< E.param (E.nonNullable E.uuid) + , view #messageId >$< E.param (E.nonNullable E.text) + , view #source >$< E.param (E.nonNullable E.text) + , view #destination >$< E.param (E.nonNullable E.text) + , view #messageKey >$< E.param (E.nullable E.text) + , view #eventType >$< E.param (E.nonNullable E.text) + , view #schemaVersion >$< E.param (E.nonNullable E.int8) + , view #contentType >$< E.param (E.nonNullable E.text) + , view #schemaRegistry >$< E.param (E.nullable E.text) + , view #schemaSubject >$< E.param (E.nullable E.text) + , view #schemaVersionRef >$< E.param (E.nullable E.int8) + , view #schemaId >$< E.param (E.nullable E.int8) + , view #schemaFingerprint >$< E.param (E.nullable E.text) + , view #sourceEventId >$< E.param (E.nullable E.uuid) + , view #sourceGlobalPosition >$< E.param (E.nullable E.int8) + , view #causationId >$< E.param (E.nullable E.uuid) + , view #correlationId >$< E.param (E.nullable E.uuid) + , view #traceparent >$< E.param (E.nullable E.text) + , view #tracestate >$< E.param (E.nullable E.text) + , view #payloadBytes >$< E.param (E.nonNullable E.bytea) + , view #attributes >$< E.param (E.nullable E.jsonb) + , view #occurredAt >$< E.param (E.nonNullable E.timestamptz) + ] + +-- --------------------------------------------------------------------------- +-- Statements +-- --------------------------------------------------------------------------- + +enqueueOutboxStmt :: Statement EncodedRow () +enqueueOutboxStmt = + preparable + """ + INSERT INTO keiro.keiro_outbox + ( outbox_id + , message_id + , source + , destination + , message_key + , event_type + , schema_version + , content_type + , schema_registry + , schema_subject + , schema_version_ref + , schema_id + , schema_fingerprint + , source_event_id + , source_global_position + , causation_id + , correlation_id + , traceparent + , tracestate + , payload_bytes + , attributes + , occurred_at + ) + VALUES + ($1, $2, $3, $4, $5, $6, $7, $8, $9, $10, $11, $12, $13, $14, $15, $16, $17, $18, $19, $20, $21, $22) + ON CONFLICT (source, message_id) DO NOTHING + """ + encodedRowEncoder + D.noResult + +claimStmt :: OrderingPolicy -> Statement (Int64, UTCTime) [OutboxRow] +claimStmt policy = + preparable + (claimSql (policyPredicates policy)) + ( contrazip2 + (E.param (E.nonNullable E.int8)) + (E.param (E.nonNullable E.timestamptz)) + ) + (D.rowList claimResultDecoder) + +data PolicyPredicates = PolicyPredicates + { preFilter :: !Text + , postFilter :: !Text + } + deriving stock (Generic) + +policyPredicates :: OrderingPolicy -> PolicyPredicates +policyPredicates = \case + PerKeyHeadOfLine -> perKeyPredicates + PerSourceStream -> perSourcePredicates + StopTheLine -> perKeyPredicates + BestEffort -> PolicyPredicates{preFilter = "TRUE", postFilter = "TRUE"} + +perKeyPredicates :: PolicyPredicates +perKeyPredicates = + PolicyPredicates + { preFilter = + """ + ( r.message_key IS NULL OR NOT EXISTS ( + SELECT 1 FROM keiro.keiro_outbox earlier + WHERE earlier.source = r.source + AND earlier.message_key = r.message_key + AND (earlier.created_at, earlier.outbox_id) < (r.created_at, r.outbox_id) + AND earlier.status NOT IN ('sent', 'dead') + AND NOT (earlier.status IN ('pending', 'failed') AND earlier.next_attempt_at <= $2) ) ) + """ + , postFilter = + """ + ( c.message_key IS NULL OR NOT EXISTS ( + SELECT 1 FROM keiro.keiro_outbox earlier + WHERE earlier.source = c.source + AND earlier.message_key = c.message_key + AND (earlier.created_at, earlier.outbox_id) < (c.created_at, c.outbox_id) + AND earlier.status NOT IN ('sent', 'dead') + AND NOT EXISTS ( + SELECT 1 FROM candidate c2 + WHERE c2.outbox_id = earlier.outbox_id ) ) ) + """ + } + +perSourcePredicates :: PolicyPredicates +perSourcePredicates = + PolicyPredicates + { preFilter = + """ + NOT EXISTS ( + SELECT 1 FROM keiro.keiro_outbox earlier + WHERE earlier.source = r.source + AND (earlier.created_at, earlier.outbox_id) < (r.created_at, r.outbox_id) + AND earlier.status NOT IN ('sent', 'dead') + AND NOT (earlier.status IN ('pending', 'failed') AND earlier.next_attempt_at <= $2) ) + """ + , postFilter = + """ + NOT EXISTS ( + SELECT 1 FROM keiro.keiro_outbox earlier + WHERE earlier.source = c.source + AND (earlier.created_at, earlier.outbox_id) < (c.created_at, c.outbox_id) + AND earlier.status NOT IN ('sent', 'dead') + AND NOT EXISTS ( + SELECT 1 FROM candidate c2 + WHERE c2.outbox_id = earlier.outbox_id ) ) + """ + } + +claimSql :: PolicyPredicates -> Text +claimSql PolicyPredicates{preFilter, postFilter} = + """ + WITH candidate AS ( + SELECT r.outbox_id, r.source, r.message_key, r.created_at + FROM keiro.keiro_outbox r + WHERE r.status IN ('pending', 'failed') + AND r.next_attempt_at <= $2 + AND ( + """ + <> preFilter + <> """ + + ) + ORDER BY r.created_at, r.outbox_id + LIMIT $1 + FOR UPDATE SKIP LOCKED + ), + ready AS ( + SELECT c.outbox_id, c.created_at AS claim_created_at + FROM candidate c + WHERE ( + """ + <> postFilter + <> """ + + ) + ), + updated AS ( + UPDATE keiro.keiro_outbox kt + SET status = 'publishing', attempt_count = kt.attempt_count + 1, updated_at = $2 + FROM ready + WHERE kt.outbox_id = ready.outbox_id + RETURNING ready.claim_created_at, + + """ + <> rowColumns + <> """ + + ) + SELECT + + """ + <> unqualifiedRowColumns + <> """ + + FROM updated + ORDER BY claim_created_at, outbox_id + """ + +rowColumns :: Text +rowColumns = + """ + kt.outbox_id, kt.message_id, kt.source, kt.destination, kt.message_key, + kt.event_type, kt.schema_version, kt.content_type, kt.schema_registry, + kt.schema_subject, kt.schema_version_ref, kt.schema_id, kt.schema_fingerprint, + kt.source_event_id, kt.source_global_position, kt.causation_id, + kt.correlation_id, kt.traceparent, kt.tracestate, kt.payload_bytes, + kt.attributes, kt.occurred_at, kt.status, kt.attempt_count, + kt.next_attempt_at, kt.last_error, kt.published_at, kt.created_at, + kt.updated_at + """ + +unqualifiedRowColumns :: Text +unqualifiedRowColumns = + """ + outbox_id, message_id, source, destination, message_key, + event_type, schema_version, content_type, schema_registry, + schema_subject, schema_version_ref, schema_id, schema_fingerprint, + source_event_id, source_global_position, causation_id, + correlation_id, traceparent, tracestate, payload_bytes, + attributes, occurred_at, status, attempt_count, + next_attempt_at, last_error, published_at, created_at, + updated_at + """ + +claimResultDecoder :: D.Row OutboxRow +claimResultDecoder = outboxRowDecoder + +countBacklogStmt :: Statement () Int +countBacklogStmt = + preparable + "SELECT COUNT(*)::bigint FROM keiro.keiro_outbox WHERE status IN ('pending', 'failed')" + E.noParams + (fmap fromIntegral (D.singleRow (D.column (D.nonNullable D.int8)))) + +gcSentStmt :: Statement UTCTime Int64 +gcSentStmt = + preparable + """ + WITH deleted AS ( + DELETE FROM keiro.keiro_outbox + WHERE status = 'sent' AND published_at < $1 + RETURNING 1 + ) + SELECT COALESCE(COUNT(*), 0)::bigint FROM deleted + """ + (E.param (E.nonNullable E.timestamptz)) + (D.singleRow (D.column (D.nonNullable D.int8))) + +readAttemptCountStmt :: Statement UUID (Maybe Int) +readAttemptCountStmt = + preparable + "SELECT attempt_count FROM keiro.keiro_outbox WHERE outbox_id = $1" + (E.param (E.nonNullable E.uuid)) + (D.rowMaybe (fromIntegral <$> D.column (D.nonNullable D.int8))) + +deadLetterStuckStmt :: Statement (UTCTime, Int64, UTCTime) Int64 +deadLetterStuckStmt = + preparable + """ + UPDATE keiro.keiro_outbox + SET status = 'dead', + last_error = COALESCE(last_error, 'reclaimed: publisher crashed mid-publish'), + updated_at = $3 + WHERE status = 'publishing' + AND updated_at <= $1 + AND attempt_count >= $2 + """ + ( contrazip3 + (E.param (E.nonNullable E.timestamptz)) + (E.param (E.nonNullable E.int8)) + (E.param (E.nonNullable E.timestamptz)) + ) + D.rowsAffected + +requeueStuckStmt :: Statement (UTCTime, Int64, UTCTime) Int64 +requeueStuckStmt = + preparable + """ + UPDATE keiro.keiro_outbox + SET status = 'failed', + updated_at = $3 + WHERE status = 'publishing' + AND updated_at <= $1 + AND attempt_count < $2 + """ + ( contrazip3 + (E.param (E.nonNullable E.timestamptz)) + (E.param (E.nonNullable E.int8)) + (E.param (E.nonNullable E.timestamptz)) + ) + D.rowsAffected + +markSentStmt :: Statement (UUID, UTCTime) Bool +markSentStmt = + preparable + """ + UPDATE keiro.keiro_outbox + SET status = 'sent', + published_at = $2, + last_error = NULL, + updated_at = $2 + WHERE outbox_id = $1 + AND status = 'publishing' + """ + ( contrazip2 + (E.param (E.nonNullable E.uuid)) + (E.param (E.nonNullable E.timestamptz)) + ) + ((> 0) <$> D.rowsAffected) + +markSentBatchStmt :: Statement ([UUID], UTCTime) Int64 +markSentBatchStmt = + preparable + """ + UPDATE keiro.keiro_outbox + SET status = 'sent', + published_at = $2, + last_error = NULL, + updated_at = $2 + WHERE outbox_id = ANY($1) + AND status = 'publishing' + """ + ( contrazip2 + (E.param (E.nonNullable (E.foldableArray (E.nonNullable E.uuid)))) + (E.param (E.nonNullable E.timestamptz)) + ) + D.rowsAffected + +markFailedStmt :: Statement (UUID, Text, Text, UTCTime, UTCTime) () +markFailedStmt = + preparable + """ + UPDATE keiro.keiro_outbox + SET status = $2, + last_error = $3, + next_attempt_at = $4, + updated_at = $5 + WHERE outbox_id = $1 + AND status = 'publishing' + """ + ( contrazip5 + (E.param (E.nonNullable E.uuid)) + (E.param (E.nonNullable E.text)) + (E.param (E.nonNullable E.text)) + (E.param (E.nonNullable E.timestamptz)) + (E.param (E.nonNullable E.timestamptz)) + ) + D.noResult + +markSkippedStmt :: Statement (UUID, Text, UTCTime) () +markSkippedStmt = + preparable + """ + UPDATE keiro.keiro_outbox + SET status = 'failed', + attempt_count = GREATEST(attempt_count - 1, 0), + last_error = $2, + next_attempt_at = $3, + updated_at = $3 + WHERE outbox_id = $1 + AND status = 'publishing' + """ + ( contrazip3 + (E.param (E.nonNullable E.uuid)) + (E.param (E.nonNullable E.text)) + (E.param (E.nonNullable E.timestamptz)) + ) + D.noResult + +lookupOutboxStmt :: Statement UUID (Maybe OutboxRow) +lookupOutboxStmt = + preparable + (selectAllSql <> " WHERE outbox_id = $1") + (E.param (E.nonNullable E.uuid)) + (D.rowMaybe outboxRowDecoder) + +listOutboxStmt :: Statement Text [OutboxRow] +listOutboxStmt = + preparable + (selectAllSql <> " WHERE source = $1 ORDER BY created_at, outbox_id") + (E.param (E.nonNullable E.text)) + (D.rowList outboxRowDecoder) + +selectAllSql :: Text +selectAllSql = + """ + SELECT outbox_id, message_id, source, destination, message_key, event_type, + schema_version, content_type, schema_registry, schema_subject, + schema_version_ref, schema_id, schema_fingerprint, source_event_id, + source_global_position, causation_id, correlation_id, traceparent, + tracestate, payload_bytes, attributes, occurred_at, status, + attempt_count, next_attempt_at, last_error, published_at, created_at, + updated_at + FROM keiro.keiro_outbox + """ + +outboxRowDecoder :: D.Row OutboxRow +outboxRowDecoder = fmap assembleRow rawRowDecoder + +data RawRow = RawRow + { outboxId :: !OutboxId + , messageId :: !Text + , source :: !Text + , destination :: !Text + , key :: !(Maybe Text) + , eventType :: !Text + , schemaVersion :: !Int + , contentType :: !Text + , schemaRegistry :: !(Maybe Text) + , schemaSubject :: !(Maybe Text) + , schemaVersionRef :: !(Maybe Int) + , schemaId :: !(Maybe Int64) + , schemaFingerprint :: !(Maybe Text) + , sourceEventId :: !(Maybe EventId) + , sourceGlobalPosition :: !(Maybe GlobalPosition) + , causationId :: !(Maybe EventId) + , correlationId :: !(Maybe EventId) + , traceparent :: !(Maybe Text) + , tracestate :: !(Maybe Text) + , payloadBytes :: !ByteString + , attributes :: !(Maybe Value) + , occurredAt :: !UTCTime + , status :: !OutboxStatus + , attemptCount :: !Int + , nextAttemptAt :: !UTCTime + , lastError :: !(Maybe Text) + , publishedAt :: !(Maybe UTCTime) + , createdAt :: !UTCTime + , updatedAt :: !UTCTime + } + deriving stock (Generic) + +rawRowDecoder :: D.Row RawRow +rawRowDecoder = + RawRow + <$> (OutboxId <$> D.column (D.nonNullable D.uuid)) + <*> D.column (D.nonNullable D.text) + <*> D.column (D.nonNullable D.text) + <*> D.column (D.nonNullable D.text) + <*> D.column (D.nullable D.text) + <*> D.column (D.nonNullable D.text) + <*> (fromIntegral <$> D.column (D.nonNullable D.int8)) + <*> D.column (D.nonNullable D.text) + <*> D.column (D.nullable D.text) + <*> D.column (D.nullable D.text) + <*> (fmap fromIntegral <$> D.column (D.nullable D.int8)) + <*> D.column (D.nullable D.int8) + <*> D.column (D.nullable D.text) + <*> (fmap EventId <$> D.column (D.nullable D.uuid)) + <*> (fmap GlobalPosition <$> D.column (D.nullable D.int8)) + <*> (fmap EventId <$> D.column (D.nullable D.uuid)) + <*> (fmap EventId <$> D.column (D.nullable D.uuid)) + <*> D.column (D.nullable D.text) + <*> D.column (D.nullable D.text) + <*> D.column (D.nonNullable D.bytea) + <*> D.column (D.nullable D.jsonb) + <*> D.column (D.nonNullable D.timestamptz) + <*> D.column (D.nonNullable (D.refine parseStatus D.text)) + <*> (fromIntegral <$> D.column (D.nonNullable D.int8)) + <*> D.column (D.nonNullable D.timestamptz) + <*> D.column (D.nullable D.text) + <*> D.column (D.nullable D.timestamptz) + <*> D.column (D.nonNullable D.timestamptz) + <*> D.column (D.nonNullable D.timestamptz) + +assembleRow :: RawRow -> OutboxRow +assembleRow raw = + let traceContext = case raw ^. #traceparent of + Nothing -> Nothing + Just tp -> Just (TraceContext tp (raw ^. #tracestate)) + schemaReference = + case ( raw ^. #schemaRegistry + , raw ^. #schemaSubject + , raw ^. #schemaVersionRef + , raw ^. #schemaId + , raw ^. #schemaFingerprint + ) of + (Nothing, Nothing, Nothing, Nothing, Nothing) -> Nothing + _ -> + Just + ( SchemaReference + (raw ^. #schemaRegistry) + (raw ^. #schemaSubject) + (raw ^. #schemaVersionRef) + (raw ^. #schemaId) + (raw ^. #schemaFingerprint) + ) + event = + IntegrationEvent + { messageId = raw ^. #messageId + , source = raw ^. #source + , destination = raw ^. #destination + , key = raw ^. #key + , eventType = raw ^. #eventType + , schemaVersion = raw ^. #schemaVersion + , contentType = parseContentType (raw ^. #contentType) + , schemaReference + , sourceEventId = raw ^. #sourceEventId + , sourceGlobalPosition = raw ^. #sourceGlobalPosition + , payloadBytes = raw ^. #payloadBytes + , occurredAt = raw ^. #occurredAt + , causationId = raw ^. #causationId + , correlationId = raw ^. #correlationId + , traceContext + , attributes = raw ^. #attributes + } + in OutboxRow + { outboxId = raw ^. #outboxId + , event + , status = raw ^. #status + , attemptCount = raw ^. #attemptCount + , nextAttemptAt = raw ^. #nextAttemptAt + , lastError = raw ^. #lastError + , publishedAt = raw ^. #publishedAt + , createdAt = raw ^. #createdAt + , updatedAt = raw ^. #updatedAt + } diff --git a/src/Keiro/Outbox/Types.hs b/src/Keiro/Outbox/Types.hs new file mode 100644 --- /dev/null +++ b/src/Keiro/Outbox/Types.hs @@ -0,0 +1,277 @@ +{- | Shared types for the durable integration-event outbox. + +The outbox is the durable handoff between "this service has decided to +publish this integration event" and "this service has actually published +it". The producer subscription writes one outbox row per mapped private +event; the publisher worker drains rows into Kafka and marks each one +sent, retryable, or dead. +-} +module Keiro.Outbox.Types ( + OutboxId (..), + OutboxStatus (..), + OrderingPolicy (..), + BackoffSchedule (..), + ExponentialBackoffOptions (..), + OutboxMessage (..), + OutboxRow (..), + OutboxPublishOptions (..), + OutboxPublishConfigError (..), + OutboxPublishSummary (..), + OutboxMaintenanceOptions (..), + OutboxMaintenanceSummary (..), + defaultPublishOptions, + defaultMaintenanceOptions, + mkOutboxPublishOptions, + statusText, + parseStatus, + nextDelay, +) +where + +import Data.Time.Clock (NominalDiffTime) +import Data.UUID (UUID) +import Data.UUID qualified as UUID +import Keiro.Integration.Event (IntegrationEvent) +import Keiro.Prelude +import OpenTelemetry.Trace.Core (Tracer) + +-- | Primary key of a 'keiro_outbox' row. Stable across publish retries. +newtype OutboxId = OutboxId {unOutboxId :: UUID} + deriving stock (Generic, Eq, Ord, Show) + +instance ToJSON OutboxId where + toJSON = toJSON . UUID.toText . unOutboxId + +instance FromJSON OutboxId where + parseJSON v = do + text <- parseJSON v + case UUID.fromText text of + Nothing -> fail ("OutboxId: not a UUID: " <> show text) + Just uuid -> pure (OutboxId uuid) + +{- | Lifecycle state of an outbox row. + +* 'OutboxPending' — never attempted. +* 'OutboxPublishing' — currently held by a publisher worker (between + claim and the call to mark sent/failed/dead). Rows left in this state + after a worker crash are reclaimed by 'Keiro.Outbox.outboxMaintenancePass' + after 'publishingTimeout'. +* 'OutboxSent' — Kafka acknowledged the publish; terminal. +* 'OutboxFailed' — last attempt failed; will be retried after + 'next_attempt_at'. +* 'OutboxDead' — terminal failure after 'maxAttempts' consecutive + failures. Stays in the table for operator inspection. +-} +data OutboxStatus + = OutboxPending + | OutboxPublishing + | OutboxSent + | OutboxFailed + | OutboxDead + deriving stock (Generic, Eq, Show) + +{- | Ordering policy enforced by the publisher worker's claim query. + +* 'PerKeyHeadOfLine' (default) — within a @source@, a non-terminal row + with key @k@ blocks every later row with the same key. Rows with + 'Nothing' key bypass the block (Kafka does not promise cross-key order + for null-keyed records). One stuck aggregate cannot stall traffic on + other aggregates. Ordering is based on @created_at@, which PostgreSQL + sets to transaction-start time; callers that concurrently enqueue the + same key through escape hatches must serialize those enqueues themselves + if commit order matters. +* 'PerSourceStream' — within a @source@, any non-terminal row blocks + every later row. Use when ordering matters across keys (rare). This has + the same @created_at@ concurrency caveat as 'PerKeyHeadOfLine'. +* 'StopTheLine' — any failure halts the worker until operator + intervention. Use when correctness requires manual review on every + failure. +* 'BestEffort' — failed rows do not block; explicit opt-in only. Safe + only when published events have no per-key/causal relationship. +-} +data OrderingPolicy + = PerKeyHeadOfLine + | PerSourceStream + | StopTheLine + | BestEffort + deriving stock (Generic, Eq, Show) + +-- | Knobs for 'ExponentialBackoff'. @delay = min maxDelay (initial * multiplier ^ (attempt - 1))@. +data ExponentialBackoffOptions = ExponentialBackoffOptions + { initial :: !NominalDiffTime + , maxDelay :: !NominalDiffTime + , multiplier :: !Double + } + deriving stock (Generic, Eq, Show) + +{- | Backoff curve used to compute 'next_attempt_at' after a failure. + +* 'ConstantBackoff' — fixed delay between retries. +* 'ExponentialBackoff' — exponential growth capped at @maxDelay@. +-} +data BackoffSchedule + = ConstantBackoff !NominalDiffTime + | ExponentialBackoff !ExponentialBackoffOptions + deriving stock (Generic, Eq, Show) + +{- | Compute the retry delay for an attempt number (1-based: 1 = first +failure, 2 = second failure, …). Used by 'Keiro.Outbox.Schema.markOutboxFailedTx' +to derive @next_attempt_at@. +-} +nextDelay :: BackoffSchedule -> Int -> NominalDiffTime +nextDelay (ConstantBackoff delay) _ = delay +nextDelay (ExponentialBackoff opts) attempt = + let raw = (opts ^. #initial) * realToFrac ((opts ^. #multiplier) ** fromIntegral (max 0 (attempt - 1))) + in min (opts ^. #maxDelay) raw + +{- | A request to enqueue one integration event into the outbox. Callers +generate 'outboxId' (use a random UUID for ad-hoc enqueues, a +deterministic UUID for idempotent retries from a saga/process manager). +-} +data OutboxMessage = OutboxMessage + { outboxId :: !OutboxId + , event :: !IntegrationEvent + } + deriving stock (Generic, Eq, Show) + +{- | A row read back from @keiro_outbox@. Worker code consumes these to +publish to Kafka; tests use them to assert state transitions. +-} +data OutboxRow = OutboxRow + { outboxId :: !OutboxId + , event :: !IntegrationEvent + , status :: !OutboxStatus + , attemptCount :: !Int + , nextAttemptAt :: !UTCTime + , lastError :: !(Maybe Text) + , publishedAt :: !(Maybe UTCTime) + , createdAt :: !UTCTime + , updatedAt :: !UTCTime + } + deriving stock (Generic, Eq, Show) + +{- | Knobs that govern one invocation of 'Keiro.Outbox.publishClaimedOutbox'. + +The optional 'tracer' field opts the publisher into OpenTelemetry +instrumentation: when present, the publisher opens a @Producer@-kind +span around each publish call, attributing the first row's +'IntegrationEvent.destination' (topic), 'IntegrationEvent.messageId', +and Kafka key per the messaging semantic conventions. When 'tracer' is +'Nothing' (the default) the publisher emits no spans. +-} +data OutboxPublishOptions = OutboxPublishOptions + { batchSize :: !Int + , maxAttempts :: !Int + , backoff :: !BackoffSchedule + , orderingPolicy :: !OrderingPolicy + , publishingTimeout :: !NominalDiffTime + , tracer :: !(Maybe Tracer) + } + deriving stock (Generic) + +data OutboxPublishConfigError + = InvalidOutboxBatchSize !Int + | InvalidOutboxMaxAttempts !Int + | InvalidOutboxPublishingTimeout !NominalDiffTime + | InvalidConstantBackoff !NominalDiffTime + | InvalidExponentialBackoffInitial !NominalDiffTime + | InvalidExponentialBackoffMultiplier !Double + | InvalidExponentialBackoffMaxDelay !NominalDiffTime !NominalDiffTime + deriving stock (Generic, Eq, Show) + +{- | Aggregate result of one publisher pass. + +@published + retried + dead@ equals the number of rows claimed. 'retried' +includes rows that were skipped because an earlier row in the same ordered +publish group failed; those rows are returned to @failed@ without consuming +an attempt. 'haltedOn' is populated only by 'StopTheLine' policy and names +the failed pivot row, which is already counted in 'retried' or 'dead'. +-} +data OutboxPublishSummary = OutboxPublishSummary + { claimed :: !Int + , published :: !Int + , retried :: !Int + , dead :: !Int + , haltedOn :: !(Maybe OutboxId) + } + deriving stock (Generic, Eq, Show) + +{- | Knobs for 'Keiro.Outbox.outboxMaintenancePass'. + +Schedule maintenance less frequently than publish passes; it owns crash +reclamation and backlog gauge sampling. +-} +data OutboxMaintenanceOptions = OutboxMaintenanceOptions + { maxAttempts :: !Int + , publishingTimeout :: !NominalDiffTime + } + deriving stock (Generic, Eq, Show) + +-- | Result of one outbox maintenance pass. +data OutboxMaintenanceSummary = OutboxMaintenanceSummary + { requeued :: !Int + , deadLettered :: !Int + , backlog :: !Int + } + deriving stock (Generic, Eq, Show) + +{- | Sensible defaults: batch of 32, ten retry attempts, two-second +constant backoff, per-key head-of-line ordering. +-} +defaultPublishOptions :: OutboxPublishOptions +defaultPublishOptions = + OutboxPublishOptions + { batchSize = 32 + , maxAttempts = 10 + , backoff = ConstantBackoff 2 + , orderingPolicy = PerKeyHeadOfLine + , publishingTimeout = 300 + , tracer = Nothing + } + +-- | Maintenance defaults match the publisher's retry ceiling and stale-row timeout. +defaultMaintenanceOptions :: OutboxMaintenanceOptions +defaultMaintenanceOptions = + OutboxMaintenanceOptions + { maxAttempts = defaultPublishOptions ^. #maxAttempts + , publishingTimeout = defaultPublishOptions ^. #publishingTimeout + } + +-- | Validate outbox publisher options before starting a worker. +mkOutboxPublishOptions :: OutboxPublishOptions -> Either OutboxPublishConfigError OutboxPublishOptions +mkOutboxPublishOptions opts + | opts ^. #batchSize < 1 = Left (InvalidOutboxBatchSize (opts ^. #batchSize)) + | opts ^. #maxAttempts < 1 = Left (InvalidOutboxMaxAttempts (opts ^. #maxAttempts)) + | opts ^. #publishingTimeout <= 0 = Left (InvalidOutboxPublishingTimeout (opts ^. #publishingTimeout)) + | otherwise = opts <$ validateBackoff (opts ^. #backoff) + +validateBackoff :: BackoffSchedule -> Either OutboxPublishConfigError () +validateBackoff = \case + ConstantBackoff delay + | delay < 0 -> Left (InvalidConstantBackoff delay) + | otherwise -> Right () + ExponentialBackoff backoff + | backoff ^. #initial <= 0 -> Left (InvalidExponentialBackoffInitial (backoff ^. #initial)) + | backoff ^. #multiplier < 1 -> Left (InvalidExponentialBackoffMultiplier (backoff ^. #multiplier)) + | backoff ^. #maxDelay < backoff ^. #initial -> + Left (InvalidExponentialBackoffMaxDelay (backoff ^. #initial) (backoff ^. #maxDelay)) + | otherwise -> Right () + +-- | Wire representation of 'OutboxStatus' used in the @status@ column. +statusText :: OutboxStatus -> Text +statusText = \case + OutboxPending -> "pending" + OutboxPublishing -> "publishing" + OutboxSent -> "sent" + OutboxFailed -> "failed" + OutboxDead -> "dead" + +-- | Inverse of 'statusText'. Unknown database values are decode failures. +parseStatus :: Text -> Either Text OutboxStatus +parseStatus = \case + "pending" -> Right OutboxPending + "publishing" -> Right OutboxPublishing + "sent" -> Right OutboxSent + "failed" -> Right OutboxFailed + "dead" -> Right OutboxDead + bad -> Left ("unknown keiro_outbox.status: " <> bad) diff --git a/src/Keiro/ProcessManager.hs b/src/Keiro/ProcessManager.hs new file mode 100644 --- /dev/null +++ b/src/Keiro/ProcessManager.hs @@ -0,0 +1,731 @@ +{- | Stateful coordination across aggregates: the process manager (saga). + +A 'ProcessManager' reacts to an incoming event by stepping its /own/ state +machine — a private \"manager\" event stream, keyed by a correlation id — and, +in the same turn, dispatching commands to /target/ aggregates and scheduling +timers. It is the stateful counterpart of "Keiro.Router": where a router +resolves targets from a read model and holds no state, a process manager +folds the events it has seen into durable manager state and decides what to +do next from that state. + +Every write — the manager-state append, each dispatched command, each timer +— is keyed by a 'deterministicCommandId' derived from +@(name, correlation, source event id, emit index)@. The manager pre-checks +each id with 'eventAlreadyIn' and folds the store's duplicate rejection into +a benign 'PMCommandDuplicate' \/ 'PMStateDuplicate'. Replaying the same +source event therefore appends nothing new, which is what makes the worker +crash-safe under at-least-once delivery. + +Use 'runProcessManagerOnce' to react to a single event, or +'runProcessManagerWorker' to run the manager as a live subscription over a +Shibuya adapter. Worker acks are finalized exactly once: successful and duplicate +dispatches ack 'AckOk', transient store failures retry, systemic deterministic +failures halt, rejection-class failures follow 'RejectedCommandPolicy', and +undecodable messages follow the configured 'PoisonPolicy'. + +=== Rejected commands and saga history + +'RejectedHalt' is the safe default: the subscription stops without advancing, +so an operator cannot miss the failure. 'RejectedDeadLetter' instead writes a +durable "Keiro.DeadLetter.DispatchDeadLetter" and acknowledges the source +event; 'RejectedSkip' acknowledges and records only the metric. Prefer making a +target command total in its Keiki transducer (for example, an explicit no-op +transition for a benign business rejection) so no policy escape hatch is +needed. + +For a process manager, dead-lettering a target dispatch creates an important +history split: the manager's own state stream has recorded its reaction, but +the target command never applied. Keiro cannot append a generic correction to +the manager stream because an event unknown to the manager's transducer would +make that stream fail replay. If saga history must reflect the failure, model a +domain-specific @DispatchFailed@-style command and event in the manager and +drive it from 'Keiro.DeadLetter.listDispatchDeadLetters' through an operator +runbook or automation. Otherwise, the dead-letter row is the durable witness. +Manager-state rejection itself has no such split because no manager event was +appended; its record uses emit index @-1@. + +=== Bounded retries and source-event dead letters + +On a Kiroku-backed Shibuya adapter, a transient failure finalizes 'AckRetry', +but retries are bounded by the Kiroku subscription's @RetryPolicy@. Its +@retryMaxAttempts@ counts total deliveries and defaults to five. When the bound +is exhausted, Kiroku records the /source event/ in @kiroku.dead_letters@ with +structured reason kind @max_attempts_exceeded@ and atomically advances the +checkpoint. The manager will not see that event again unless an operator +replays it through @Keiro.DeadLetter.Replay@. Install +'Keiro.Telemetry.kirokuEventBridge' on Kiroku's @eventHandler@ to observe the +terminal transition. + +The adapter's @KirokuAdapterConfig@ does not currently expose @retryPolicy@, so +that path uses Kiroku's default bound. The sharded path is configurable: +'Keiro.Subscription.Shard.Worker.runShardedSubscriptionGroupAck' forwards +'Keiro.Subscription.Shard.Worker.ShardedWorkerOptions.retryPolicy' into the +same Kiroku acknowledgement ladder. A shard handler that dispatches commands +can use 'decideForFailures' and 'isRejectionClass' to classify outcomes, then +map the decision to its existing @ShardAck@ reply. + +=== Correlation, ordering, and transaction boundaries + +Events from one originating stream retain that stream's append order. Kiroku +consumer groups hash the originating stream id to a stable member, so sharding +does not split one stream across readers. Events from /different/ streams that +'correlate' to the same manager instance have no business-order guarantee, +however. Their append transactions race for global positions and, under +sharding, the streams may be processed concurrently by different members. A +retry on one member does not stop another member from advancing. + +For example, both @payment-ORD1@'s @PaymentCaptured@ and @shipment-ORD1@'s +@ShipmentAllocated@ may correlate to order @ORD1@. The manager must accept +@PaymentCaptured@ then @ShipmentAllocated@ /and/ the reverse, normally with +states that record one fact while waiting for the other. An unsharded Kiroku +subscription processes its observed global order serially, including retries, +but that order still reflects append timing rather than a domain sequence. + +Rule of thumb: 'correlate' may join streams freely, but every such join must be +order-insensitive. When a strict sequence is required, enforce it in the +manager's own state machine — for example with an explicit no-op/waiting state +and a timer-driven retry, or a modeled rejection handled by the dead-letter +policy — never by assuming delivery order. + +The persistence boundary is also intentionally smaller than one whole saga +reaction. A manager event and its timers commit together when the manager +command appends; a timer-only no-op reaction schedules its timers in a separate +transaction. Each target command and its inline projections then commit in +their own transaction. A crash or rejected target can therefore leave durable +manager history without every target write. Deterministic ids make source-event +replay fill the missing writes without duplicating completed ones; the rejected +command section above describes the case that is deliberately acknowledged +instead. +-} +module Keiro.ProcessManager ( + -- * Definition + ProcessManager (..), + ProcessManagerAction (..), + PMCommand (..), + + -- * Results + ProcessManagerResult (..), + PMCommandResult (..), + PMStateResult (..), + + -- * Running + PoisonPolicy (..), + RejectedCommandPolicy (..), + DispatchFailure (..), + WorkerOptions (..), + defaultWorkerOptions, + isTransientStoreError, + isTransientCommandError, + isRejectionClass, + decideForFailures, + ackForCommandError, + runProcessManagerOnce, + runProcessManagerWorkerWith, + runProcessManagerWorker, + + -- * Idempotency primitives + deterministicCommandId, + eventAlreadyIn, + confirmBenignDuplicate, +) +where + +import Data.Coerce (coerce) +import Data.Text qualified as Text +import Data.UUID qualified as UUID +import Data.UUID.V5 qualified as UUID.V5 +import Effectful (Eff, IOE, (:>)) +import Effectful.Error.Static (Error, tryError) +import GHC.Stack (HasCallStack) +import Keiki.Core (BoolAlg, RegFile) +import Keiro.Command (CommandError (..), CommandResult, RunCommandOptions, commandErrorClass, runCommandWithSql) +import Keiro.DeadLetter (DispatchDeadLetter (..), DispatcherKind (..), recordDispatchDeadLetter) +import Keiro.EventStream (EventStream) +import Keiro.EventStream.Validate (ValidatedEventStream, unvalidated) +import Keiro.Prelude +import Keiro.Projection (InlineProjection, runCommandWithProjections) +import Keiro.Stream (Stream) +import Keiro.Telemetry (KeiroMetrics, recordDispatchDeadLettered, recordDispatchDuplicate, recordDispatchFailed, recordDispatchPoison) +import Keiro.Timer (TimerRequest, scheduleTimerTx) +import Kiroku.Store.Effect (Store) +import Kiroku.Store.Effect.Resource (KirokuStoreResource) +import Kiroku.Store.Error (StoreError (..)) +import Kiroku.Store.Read (eventExistsInStream) +import Kiroku.Store.Transaction (runTransaction) +import Kiroku.Store.Types (EventId (..), RecordedEvent) +import Kiroku.Store.Types qualified as StoreTypes +import Shibuya.Adapter (Adapter (..)) +import Shibuya.Core.Ack (AckDecision (..), DeadLetterReason (..), HaltReason (..), RetryDelay (..)) +import Shibuya.Core.AckHandle (AckHandle (..)) +import Shibuya.Core.Ingested (Ingested (..)) +import Shibuya.Core.Types (Attempt (..), Envelope (..)) +import Streamly.Data.Fold qualified as Fold +import Streamly.Data.Stream qualified as Streamly +import Prelude (any, filter, fromIntegral, length, not, uncurry, zip, (&&), (+)) + +{- | A process manager wiring together a manager state machine and the target +aggregate it drives. + +* 'name' — stable identity; part of every deterministic write id. +* 'correlate' — derives the correlation key for an input event, selecting + which manager instance handles it. +* 'eventStream' — the manager's own 'EventStream'; its events record the + saga's progress. +* 'streamFor' — maps a correlation key to the manager's 'Stream' handle. +* 'targetEventStream' — the aggregate that dispatched commands are sent to. +* 'targetProjections' — inline projections for the target aggregate, run in + the same transaction as each dispatched command's append. Return @[]@ for + append-only dispatch. +* 'handle' — the pure reaction: given an input event, produce the + manager-state command, the target commands to dispatch, and any timers to + schedule. +-} +data ProcessManager input phi rs s ci co targetPhi targetRs targetState targetCi targetCo = ProcessManager + { name :: !Text + , correlate :: !(input -> Text) + , eventStream :: !(ValidatedEventStream phi rs s ci co) + , streamFor :: !(Text -> Stream (EventStream phi rs s ci co)) + , targetEventStream :: !(ValidatedEventStream targetPhi targetRs targetState targetCi targetCo) + , targetProjections :: !(Stream targetCi -> [InlineProjection targetCo]) + {- ^ Inline projections for the target aggregate, run in the same transaction + as each dispatched command's append. Return @[]@ for append-only dispatch. + -} + , handle :: !(input -> ProcessManagerAction ci targetCi) + } + deriving stock (Generic) + +{- | What a process manager decides to do for one input event: advance its own +state with 'command', dispatch zero or more target 'commands', and schedule +zero or more 'timers'. All three are applied atomically with crash-safe +idempotency by 'runProcessManagerOnce'. +-} +data ProcessManagerAction ci targetCi = ProcessManagerAction + { command :: !ci + , commands :: ![PMCommand targetCi] + , timers :: ![TimerRequest] + } + deriving stock (Generic) + +-- | A single command addressed to a specific target stream. +data PMCommand targetCi = PMCommand + { target :: !(Stream targetCi) + , command :: !targetCi + } + deriving stock (Generic, Eq, Show) + +-- | Outcome of one dispatched target command. +data PMCommandResult target + = -- | The command appended events (carries the 'CommandResult'). + PMCommandAppended !(CommandResult target) + | {- | The command was already applied (idempotent replay); carries the + deterministic id that already existed. + -} + PMCommandDuplicate !EventId + | {- | The command failed in the named target stream; the worker classifies + the error. Transient failures retry, rejection-class failures follow + 'RejectedCommandPolicy', and systemic deterministic failures halt. + -} + PMCommandFailed !StoreTypes.StreamName !CommandError + deriving stock (Generic, Eq, Show) + +{- | Outcome of the manager's own state append. Unlike 'PMCommandResult' there +is no failure case — a manager-state append that genuinely errors aborts the +whole reaction via an outer @Left@ 'CommandError'. +-} +data PMStateResult target + = PMStateAppended !(CommandResult target) + | PMStateDuplicate !EventId + deriving stock (Generic, Eq, Show) + +{- | The complete result of reacting to one event: how the manager state +advanced, the outcome of each dispatched command in order, and how many +timers were scheduled. +-} +data ProcessManagerResult managerTarget commandTarget = ProcessManagerResult + { managerResult :: !(PMStateResult managerTarget) + , commandResults :: ![PMCommandResult commandTarget] + , timersScheduled :: !Int + } + deriving stock (Generic, Eq, Show) + +-- | What a worker does with a message its decoder cannot parse. +data PoisonPolicy es msg + = PoisonHalt + | PoisonSkip !(Envelope msg -> Eff es ()) + | PoisonDeadLetter !(Envelope msg -> Eff es ()) + +-- | What a worker does when every failed dispatch is a rejection-class error. +data RejectedCommandPolicy + = -- | Halt without acknowledging so the source event replays. This is the default. + RejectedHalt + | -- | Persist a durable dispatch dead letter and acknowledge the source event. + RejectedDeadLetter + | -- | Acknowledge and count the rejection without persisting a record. + RejectedSkip + deriving stock (Generic, Eq, Show) + +-- | One failed dispatch with the target identity needed by worker policy. +data DispatchFailure = DispatchFailure + { emitIndex :: !Int + , targetStreamName :: !StoreTypes.StreamName + , commandError :: !CommandError + } + deriving stock (Generic, Eq, Show) + +-- | Worker-level knobs shared by the process-manager and router workers. +data WorkerOptions es msg = WorkerOptions + { poisonPolicy :: !(PoisonPolicy es msg) + , rejectedCommandPolicy :: !RejectedCommandPolicy + , transientRetryDelay :: !RetryDelay + , metrics :: !(Maybe KeiroMetrics) + } + deriving stock (Generic) + +defaultWorkerOptions :: WorkerOptions es msg +defaultWorkerOptions = + WorkerOptions + { poisonPolicy = PoisonHalt + , rejectedCommandPolicy = RejectedHalt + , transientRetryDelay = RetryDelay 5 + , metrics = Nothing + } + +isTransientStoreError :: StoreError -> Bool +isTransientStoreError = \case + ConnectionLost{} -> True + PoolAcquisitionTimeout -> True + ConnectionError{} -> True + WrongExpectedVersion{} -> True + StreamAlreadyExists{} -> True + EmptyAppendBatch{} -> False + StreamNotFound{} -> False + ReservedStreamName{} -> False + StreamNameTooLong{} -> False + DuplicateEvent{} -> False + EventAlreadyLinked{} -> False + LinkSourceEventMissing{} -> False + UnexpectedServerError{} -> False + +isTransientCommandError :: CommandError -> Bool +isTransientCommandError = \case + StoreFailed err -> isTransientStoreError err + RetryExhausted _ err -> isTransientStoreError err + ConflictFixpoint _ err -> isTransientStoreError err + HydrationDecodeFailed{} -> False + HydrationReplayFailed{} -> False + HydrationGapDetected{} -> False + CommandRejected -> False + CommandAmbiguous{} -> False + EncodeFailed{} -> False + +-- | Whether a command error is a per-command rejection covered by worker policy. +isRejectionClass :: CommandError -> Bool +isRejectionClass = \case + CommandRejected -> True + CommandAmbiguous{} -> True + _ -> False + +{- | Classify a group of failed dispatches and choose one acknowledgement. + +Systemic deterministic errors always halt. Any transient error retries the +whole source event. Only an all-rejection group reaches the configured +'RejectedCommandPolicy'. Dead-letter writes are idempotent under redelivery. +-} +decideForFailures :: + (IOE :> es, Store :> es) => + WorkerOptions es msg -> + DispatcherKind -> + Text -> + Text -> + RecordedEvent -> + Int -> + [DispatchFailure] -> + Eff es AckDecision +decideForFailures workerOptions dispatcherKind dispatcherName correlationId sourceEvent attemptCount failures = + case filter isSystemicDeterministic failures of + failure : _ -> pure (haltFor failure) + [] + | any (isTransientCommandError . (^. #commandError)) failures -> + pure (AckRetry (workerOptions ^. #transientRetryDelay)) + | otherwise -> + case failures of + [] -> pure AckOk + _ -> decideRejected + where + isSystemicDeterministic failure = + let err = failure ^. #commandError + in not (isTransientCommandError err) && not (isRejectionClass err) + + haltFor failure = + AckHalt (HaltFatal (Text.pack (show (failure ^. #commandError)))) + + decideRejected = + case workerOptions ^. #rejectedCommandPolicy of + RejectedHalt -> pure (haltFor (headFailure failures)) + RejectedDeadLetter -> do + traverse_ recordFailure failures + recordHandled + pure AckOk + RejectedSkip -> do + recordHandled + pure AckOk + + recordHandled = + recordDispatchDeadLettered + (workerOptions ^. #metrics) + (fromIntegral (length failures)) + + recordFailure failure = + let err = failure ^. #commandError + in recordDispatchDeadLetter + DispatchDeadLetter + { dispatcherKind = dispatcherKind + , dispatcherName = dispatcherName + , correlationId = correlationId + , sourceEventId = sourceEvent ^. #eventId + , sourceGlobalPosition = sourceEvent ^. #globalPosition + , emitIndex = failure ^. #emitIndex + , targetStreamName = failure ^. #targetStreamName + , errorClass = commandErrorClass err + , errorDetail = Text.pack (show err) + , attemptCount = max 1 attemptCount + } + + headFailure = \case + failure : _ -> failure + [] -> DispatchFailure (-1) (StoreTypes.StreamName "unknown") CommandRejected + +ackForCommandError :: RetryDelay -> CommandError -> AckDecision +ackForCommandError delay err + | isTransientCommandError err = AckRetry delay + | otherwise = AckHalt (HaltFatal (Text.pack (show err))) + +{- | Derive a stable, collision-resistant 'EventId' for a manager write from +@(manager name, correlation id, source event id, emit index)@ via a v5 UUID. + +The same inputs always yield the same id, so a replayed source event +produces the same write ids and the store's uniqueness constraint collapses +the duplicate. The manager-state append uses an emit index of @-1@ to keep +it distinct from the dispatched commands (which start at @0@). This positional +index is sound because 'handle' is pure and therefore returns the same command +order for the same input. The effectful router uses +'Keiro.Router.deterministicRouterCommandId' instead, retaining this positional +id only as a transition probe for pre-upgrade router dispatches. +-} +deterministicCommandId :: Text -> Text -> EventId -> Int -> EventId +deterministicCommandId managerName correlationId sourceEventId emitIndex = + EventId + $ UUID.V5.generateNamed UUID.V5.namespaceURL + $ fmap (fromIntegral . fromEnum) + $ Text.unpack + $ Text.intercalate + ":" + [ "keiro" + , "process-manager" + , managerName + , correlationId + , UUID.toText (eventIdToUuid sourceEventId) + , Text.pack (show emitIndex) + ] + +{- | React to a single source event: advance the manager's state, dispatch +its target commands, and schedule its timers — each under a deterministic, +idempotent write id. + +The manager-state append and its timers commit in one transaction; each +target command is then dispatched (with its inline projections) in its own. +A duplicate manager append short-circuits to 'PMStateDuplicate' but still +re-runs the dispatch loop, so a crash between the state append and a +command dispatch is recovered on replay. Returns @Left@ only when the +manager-state append fails for a non-duplicate reason; per-command failures +are reported inside 'commandResults'. +-} +runProcessManagerOnce :: + forall input phi rs s ci co targetPhi targetRs targetState targetCi targetCo es. + ( HasCallStack + , IOE :> es + , Store :> es + , Error StoreError :> es + , KirokuStoreResource :> es + , BoolAlg phi (RegFile rs, ci) + , BoolAlg targetPhi (RegFile targetRs, targetCi) + , Eq co + , Eq targetCo + ) => + RunCommandOptions -> + ProcessManager input phi rs s ci co targetPhi targetRs targetState targetCi targetCo -> + RecordedEvent -> + input -> + Eff es (Either CommandError (ProcessManagerResult (EventStream phi rs s ci co) (EventStream targetPhi targetRs targetState targetCi targetCo))) +runProcessManagerOnce options manager sourceEvent input = do + let correlationId = (manager ^. #correlate) input + action = (manager ^. #handle) input + managerStream = (manager ^. #streamFor) correlationId + managerEventId = deterministicCommandId (manager ^. #name) correlationId (sourceEvent ^. #eventId) (-1) + managerOptions = options & #eventIds .~ [managerEventId] + managerStreamName = ((unvalidated (manager ^. #eventStream)) ^. #resolveStreamName) managerStream + managerAlreadyProcessed <- eventAlreadyIn options managerStreamName managerEventId + if managerAlreadyProcessed + then finish correlationId (PMStateDuplicate managerEventId) action + else do + managerOutcome <- + runCommandWithSql + managerOptions + (manager ^. #eventStream) + managerStream + (action ^. #command) + (\_ -> traverse_ scheduleTimerTx (action ^. #timers)) + case managerOutcome of + Left err -> do + benign <- confirmBenignDuplicate managerStreamName managerEventId err + if benign + then finish correlationId (PMStateDuplicate managerEventId) action + else pure (Left err) + Right (managerResult, scheduledInAppend) -> do + -- No-op manager commands do not execute runCommandWithSql's callback, + -- so schedule timer-only reactions explicitly. + case scheduledInAppend of + Nothing -> runTransaction (traverse_ scheduleTimerTx (action ^. #timers)) + Just () -> pure () + finish correlationId (PMStateAppended managerResult) action + where + finish correlationId managerResult action = do + commandResults <- dispatchCommands correlationId (sourceEvent ^. #eventId) (action ^. #commands) + pure + $ Right + ProcessManagerResult + { managerResult = managerResult + , commandResults = commandResults + , timersScheduled = length (action ^. #timers) + } + + dispatchCommands correlationId sourceEventId commands = + traverse + (uncurry (dispatchCommand correlationId sourceEventId)) + (zip [0 ..] commands) + + dispatchCommand correlationId sourceEventId emitIndex command = do + let commandId = deterministicCommandId (manager ^. #name) correlationId sourceEventId emitIndex + targetOptions = options & #eventIds .~ [commandId] + targetStream = retarget (command ^. #target) + targetStreamName = ((unvalidated (manager ^. #targetEventStream)) ^. #resolveStreamName) targetStream + commandAlreadyProcessed <- eventAlreadyIn options targetStreamName commandId + if commandAlreadyProcessed + then pure (PMCommandDuplicate commandId) + else do + outcome <- + runCommandWithProjections + targetOptions + (manager ^. #targetEventStream) + targetStream + (command ^. #command) + ((manager ^. #targetProjections) (command ^. #target)) + case outcome of + Right result -> pure (PMCommandAppended result) + Left err -> do + benign <- confirmBenignDuplicate targetStreamName commandId err + pure $ if benign then PMCommandDuplicate commandId else PMCommandFailed targetStreamName err + + retarget :: Stream targetCi -> Stream (EventStream targetPhi targetRs targetState targetCi targetCo) + retarget = coerce + +{- | Run a process manager as a live subscription draining a Shibuya adapter with +'defaultWorkerOptions'. + +Use 'runProcessManagerWorkerWith' to override poison-message handling, rejected +command handling, transient retry delay, or dispatch metrics. Every ingested message's ack handle is +finalized exactly once. Successful and duplicate dispatches finalize 'AckOk'; +transient store failures finalize 'AckRetry'; rejection-class failures follow +'RejectedCommandPolicy'; other deterministic failures finalize 'AckHalt'; +undecodable messages follow the configured 'PoisonPolicy'. Under +'RejectedDeadLetter', see the module-level saga-history contract before opting +in. On a Kiroku-backed adapter, each 'AckRetry' redelivery is bounded by the +subscription @RetryPolicy@ (five total deliveries by default). Exhaustion +dead-letters the source event in @kiroku.dead_letters@ and advances the +checkpoint; @KirokuAdapterConfig@ does not currently expose that bound. Observe +the terminal event with 'Keiro.Telemetry.kirokuEventBridge' and replay it with +@Keiro.DeadLetter.Replay@ when appropriate. +-} +runProcessManagerWorker :: + forall msg input phi rs s ci co targetPhi targetRs targetState targetCi targetCo es. + ( HasCallStack + , IOE :> es + , Store :> es + , Error StoreError :> es + , KirokuStoreResource :> es + , BoolAlg phi (RegFile rs, ci) + , BoolAlg targetPhi (RegFile targetRs, targetCi) + , Eq co + , Eq targetCo + ) => + RunCommandOptions -> + ProcessManager input phi rs s ci co targetPhi targetRs targetState targetCi targetCo -> + Adapter es msg -> + (msg -> Maybe (RecordedEvent, input)) -> + Eff es () +runProcessManagerWorker = + runProcessManagerWorkerWith defaultWorkerOptions + +runProcessManagerWorkerWith :: + forall msg input phi rs s ci co targetPhi targetRs targetState targetCi targetCo es. + ( HasCallStack + , IOE :> es + , Store :> es + , Error StoreError :> es + , KirokuStoreResource :> es + , BoolAlg phi (RegFile rs, ci) + , BoolAlg targetPhi (RegFile targetRs, targetCi) + , Eq co + , Eq targetCo + ) => + WorkerOptions es msg -> + RunCommandOptions -> + ProcessManager input phi rs s ci co targetPhi targetRs targetState targetCi targetCo -> + Adapter es msg -> + (msg -> Maybe (RecordedEvent, input)) -> + Eff es () +runProcessManagerWorkerWith workerOptions options manager Adapter{source = adapterSource} decodeMessage = + Streamly.fold Fold.drain + $ Streamly.mapM handleIngested adapterSource + where + handleIngested :: Ingested es msg -> Eff es AckDecision + handleIngested Ingested{envelope = env@Envelope{payload = message}, ack = AckHandle finalizeAck} = do + decision <- case decodeMessage message of + Nothing -> decideForPoison workerOptions "process-manager worker could not decode message" env + Just (recorded, input) -> do + let correlationId = (manager ^. #correlate) input + managerStream = (manager ^. #streamFor) correlationId + managerStreamName = ((unvalidated (manager ^. #eventStream)) ^. #resolveStreamName) managerStream + attemptCount = envelopeAttemptCount env + outcome <- tryError @StoreError (runProcessManagerOnce options manager recorded input) + case outcome of + Left (_, storeErr) -> do + recordDispatchFailed (workerOptions ^. #metrics) 1 + pure (ackForThrownStoreError (workerOptions ^. #transientRetryDelay) storeErr) + Right (Left err) -> do + recordDispatchFailed (workerOptions ^. #metrics) 1 + decideForFailures + workerOptions + DispatcherProcessManager + (manager ^. #name) + correlationId + recorded + attemptCount + [DispatchFailure (-1) managerStreamName err] + Right (Right result) -> + ackForResults + workerOptions + (manager ^. #name) + correlationId + recorded + attemptCount + (result ^. #managerResult) + (result ^. #commandResults) + finalizeAck decision + pure decision + +ackForThrownStoreError :: RetryDelay -> StoreError -> AckDecision +ackForThrownStoreError delay = ackForCommandError delay . StoreFailed + +ackForResults :: + (IOE :> es, Store :> es) => + WorkerOptions es msg -> + Text -> + Text -> + RecordedEvent -> + Int -> + PMStateResult managerTarget -> + [PMCommandResult commandTarget] -> + Eff es AckDecision +ackForResults workerOptions managerName correlationId sourceEvent attemptCount managerResult commandResults = do + let duplicateCount = stateDuplicateCount managerResult + commandDuplicateCount commandResults + failures = + [ DispatchFailure emitIndex targetStreamName err + | (emitIndex, PMCommandFailed targetStreamName err) <- zip [0 ..] commandResults + ] + recordDispatchDuplicate (workerOptions ^. #metrics) duplicateCount + recordDispatchFailed (workerOptions ^. #metrics) (fromIntegral (length failures)) + decideForFailures + workerOptions + DispatcherProcessManager + managerName + correlationId + sourceEvent + attemptCount + failures + +stateDuplicateCount :: PMStateResult target -> Int64 +stateDuplicateCount = \case + PMStateDuplicate{} -> 1 + PMStateAppended{} -> 0 + +commandDuplicateCount :: [PMCommandResult target] -> Int64 +commandDuplicateCount = + fromIntegral . length . filter isDuplicateResult + where + isDuplicateResult = \case + PMCommandDuplicate{} -> True + _ -> False + +envelopeAttemptCount :: Envelope msg -> Int +envelopeAttemptCount env = + case env ^. #attempt of + Nothing -> 1 + Just (Attempt attempt) -> fromIntegral attempt + 1 + +decideForPoison :: + (IOE :> es) => + WorkerOptions es msg -> + Text -> + Envelope msg -> + Eff es AckDecision +decideForPoison workerOptions reason env = do + recordDispatchPoison (workerOptions ^. #metrics) 1 + case workerOptions ^. #poisonPolicy of + PoisonHalt -> pure (AckHalt (HaltFatal reason)) + PoisonSkip callback -> do + callback env + pure AckOk + PoisonDeadLetter callback -> do + callback env + pure (AckDeadLetter (InvalidPayload reason)) + +eventIdToUuid :: EventId -> UUID.UUID +eventIdToUuid (EventId uuid) = uuid + +{- | Check whether an event with the given id is already present in a live stream. +Used as the pre-dispatch idempotency guard so a +command that was already applied on a prior (possibly crashed) attempt is +recognized as a duplicate before re-running it. +-} +eventAlreadyIn :: + (Store :> es) => + RunCommandOptions -> + StoreTypes.StreamName -> + EventId -> + Eff es Bool +eventAlreadyIn _options streamName eventId = + eventExistsInStream streamName eventId + +{- | Decide whether a failed append is a benign duplicate of the write just +attempted: whether @ourId@ is genuinely present in @streamName@. + +Kiroku's @DuplicateEvent@ carries 'Just' the colliding id only when +PostgreSQL's detail string parses ('Nothing' otherwise), and because the +store's event-id uniqueness is global, even a matching id does not prove the +event landed in our stream. A mismatched id is never ours; a matching or +missing id is confirmed against the target stream with a point lookup. Callers +fold 'True' into their duplicate result and surface 'False' as the original +failure. +-} +confirmBenignDuplicate :: + (Store :> es) => + StoreTypes.StreamName -> + EventId -> + CommandError -> + Eff es Bool +confirmBenignDuplicate streamName ourId = \case + StoreFailed (DuplicateEvent (Just duplicateId)) + | duplicateId == ourId -> eventExistsInStream streamName ourId + StoreFailed (DuplicateEvent Nothing) -> eventExistsInStream streamName ourId + _ -> pure False diff --git a/src/Keiro/Projection.hs b/src/Keiro/Projection.hs new file mode 100644 --- /dev/null +++ b/src/Keiro/Projection.hs @@ -0,0 +1,250 @@ +{- | Projections: turning a stream's events into read-side state. + +Two flavors, trading consistency against coupling: + +* An 'InlineProjection' runs in the /same/ transaction as the command that + produced the events, so the read model is updated atomically with the + append — never stale, but tied to the writer's transaction and latency. + 'runCommandWithProjections' runs a command and applies a list of inline + projections to whatever it emits. +* An 'AsyncProjection' runs later from a subscription draining the event + log. It carries a 'subscriptionName' for checkpointing and an + 'idempotencyKey' so redelivery is safe; 'applyAsyncProjection' performs + one application. This decouples the read model from the writer at the + cost of eventual consistency. + +Both ultimately fold events into a SQL read model via a +'Hasql.Transaction.Transaction'; the difference is only /when/ that +transaction runs. +-} +module Keiro.Projection ( + -- * Inline projections + InlineProjection (..), + runCommandWithProjections, + + -- * Asynchronous projections + AsyncProjection (..), + AsyncApplyOutcome (..), + applyAsyncProjection, + applyAsyncProjectionUnfenced, + pruneAsyncProjectionDedupBefore, + recordProjectionLag, +) +where + +import Contravariant.Extras (contrazip2) +import Data.UUID (UUID) +import Effectful (Eff, IOE, (:>)) +import Effectful.Error.Static (Error) +import GHC.Stack (HasCallStack) +import Hasql.Decoders qualified as D +import Hasql.Encoders qualified as E +import Hasql.Statement (Statement, preparable) +import Keiki.Core (BoolAlg, RegFile) +import Keiro.Command (CommandError, CommandResult, RunCommandOptions, runCommandWithSqlEvents) +import Keiro.EventStream (EventStream) +import Keiro.EventStream.Validate (ValidatedEventStream) +import Keiro.Prelude +import Keiro.ReadModel (readSubscriptionPosition, storeHeadPosition) +import Keiro.Stream (Stream) +import Keiro.Telemetry (KeiroMetrics) +import Keiro.Telemetry qualified as Telemetry +import Kiroku.Store.Effect (Store) +import Kiroku.Store.Effect.Resource (KirokuStoreResource) +import Kiroku.Store.Error (StoreError) +import Kiroku.Store.Transaction (runTransaction) +import Kiroku.Store.Types (EventId (..), GlobalPosition (..), RecordedEvent) +import "hasql-transaction" Hasql.Transaction qualified as Tx +import Prelude qualified + +{- | A read-model update applied synchronously with the command that emits +the event. 'apply' receives both the decoded event @co@ and the +'RecordedEvent' the store persisted, and runs in the append transaction. +'name' identifies the projection for diagnostics. +-} +data InlineProjection co = InlineProjection + { name :: !Text + , apply :: !(co -> RecordedEvent -> Tx.Transaction ()) + } + deriving stock (Generic) + +{- | A read-model update applied asynchronously by a subscription worker. + +* 'name' — identifies the projection for diagnostics. +* 'readModelName' — names the registry row for the model this projection writes. +* 'subscriptionName' — the cursor under which the worker checkpoints its + progress through the event log. +* 'applyRecorded' — folds one 'RecordedEvent' into the read model. +* 'idempotencyKey' — the 'EventId' used to suppress duplicate application on + redelivery, making the projection safe to retry. +-} +data AsyncProjection = AsyncProjection + { name :: !Text + , readModelName :: !Text + , subscriptionName :: !Text + , applyRecorded :: !(RecordedEvent -> Tx.Transaction ()) + , idempotencyKey :: !(RecordedEvent -> EventId) + } + deriving stock (Generic) + +-- | The database-visible result of one asynchronous projection attempt. +data AsyncApplyOutcome + = AsyncApplied + | AsyncDuplicate + | AsyncFenced + deriving stock (Generic, Eq, Show) + +{- | Run a command and apply every supplied 'InlineProjection' to the events +it emits, all inside the command's append transaction. A projection failure +aborts the whole transaction, so the events and the read-model update commit +together or not at all. +-} +runCommandWithProjections :: + forall phi rs s ci co es. + (HasCallStack, IOE :> es, Store :> es, Error StoreError :> es, KirokuStoreResource :> es, BoolAlg phi (RegFile rs, ci), Eq co) => + RunCommandOptions -> + ValidatedEventStream phi rs s ci co -> + Stream (EventStream phi rs s ci co) -> + ci -> + [InlineProjection co] -> + Eff es (Either CommandError (CommandResult (EventStream phi rs s ci co))) +runCommandWithProjections options eventStream targetStream command projections = do + result <- + runCommandWithSqlEvents + options + eventStream + targetStream + command + ( \pairs _appendResult -> + traverse_ + ( \projection -> + traverse_ + (\(event, recorded) -> (projection ^. #apply) event recorded) + pairs + ) + projections + ) + pure (fmap Prelude.fst result) + +{- | Apply one event to a live 'AsyncProjection', returning a distinct outcome +for a successful application, a retained dedup key, or a rebuild fence. + +The registry row is read with @FOR SHARE@ inside the same transaction as the +dedup insert and application. A missing row or any status other than @live@ +returns 'AsyncFenced' without touching either table. A worker that receives +'AsyncFenced' must not checkpoint past the event: fail or park the delivery and +retry after promotion. Ack-coupled Kiroku delivery preserves the checkpoint +when its handler does not acknowledge success. + +The projection's 'idempotencyKey' is inserted into @keiro_projection_dedup@ +inside the same transaction as 'applyRecorded'. When that insert conflicts, +the event was already applied within the retained dedup window and the update +is skipped. Use 'pruneAsyncProjectionDedupBefore' only for events older than +the subscription system can redeliver; pruning intentionally re-opens those +events for application if they are replayed later. +-} +applyAsyncProjection :: AsyncProjection -> RecordedEvent -> Tx.Transaction AsyncApplyOutcome +applyAsyncProjection projection recorded = do + status <- + Tx.statement + (projection ^. #readModelName) + lockReadModelStatusStmt + case status of + Just "live" -> applyAsyncProjectionUnfenced projection recorded + _ -> pure AsyncFenced + +{- | Apply one event without consulting the read-model registry fence. + +This is exclusively the rebuild replay entry point: it retains normal dedup +semantics while permitting the designated rebuilder to write while the model is +@rebuilding@. Live workers must use 'applyAsyncProjection'. +-} +applyAsyncProjectionUnfenced :: AsyncProjection -> RecordedEvent -> Tx.Transaction AsyncApplyOutcome +applyAsyncProjectionUnfenced projection recorded = do + inserted <- + Tx.statement + (projection ^. #name, eventIdToUuid ((projection ^. #idempotencyKey) recorded)) + insertProjectionDedupStmt + if inserted + then do + (projection ^. #applyRecorded) recorded + pure AsyncApplied + else pure AsyncDuplicate + +{- | Age out async-projection dedup rows older than the supplied timestamp. + +Use this only beyond the subscription system's redelivery window; pruning +re-opens those events for application. It is not a rebuild reset. Supported +rebuilds use 'Keiro.ReadModel.Rebuild.startRebuild', which atomically deletes +only the named projections' keys while fencing writers and resetting the model. +Returns the number of rows pruned. +-} +pruneAsyncProjectionDedupBefore :: (Store :> es) => UTCTime -> Eff es Int64 +pruneAsyncProjectionDedupBefore cutoff = + runTransaction + $ Tx.statement cutoff pruneProjectionDedupBeforeStmt + +{- | Record 'keiro.projection.lag' for one async projection: how many events its +subscription is behind the global log head, computed as the store head global +position minus the subscription's checkpoint position (clamped at 0). A no-op +when no metrics handle is supplied. Call once per drain pass, after applying the +batch, so the gauge reflects the backlog the worker has left to catch up on. + +There is no in-library polling drain loop today (the application drives +'applyAsyncProjection' per event), so this is the entry point an application +calls to surface lag for a subscription. +-} +recordProjectionLag :: + (IOE :> es, Store :> es) => + Maybe KeiroMetrics -> + AsyncProjection -> + Eff es () +recordProjectionLag metrics projection = do + headPos <- storeHeadPosition + checkpoint <- + fromMaybe (GlobalPosition 0) + <$> readSubscriptionPosition (projection ^. #subscriptionName) + Telemetry.recordProjectionLag metrics (positionGap headPos checkpoint) + +-- | The non-negative gap between the log head and a checkpoint, in events. +positionGap :: GlobalPosition -> GlobalPosition -> Int64 +positionGap (GlobalPosition headP) (GlobalPosition checkP) = max 0 (headP Prelude.- checkP) + +insertProjectionDedupStmt :: Statement (Text, UUID) Bool +insertProjectionDedupStmt = + preparable + """ + INSERT INTO keiro.keiro_projection_dedup (projection_name, event_id) + VALUES ($1, $2) + ON CONFLICT (projection_name, event_id) DO NOTHING + """ + ( contrazip2 + (E.param (E.nonNullable E.text)) + (E.param (E.nonNullable E.uuid)) + ) + ((> 0) <$> D.rowsAffected) + +lockReadModelStatusStmt :: Statement Text (Maybe Text) +lockReadModelStatusStmt = + preparable + """ + SELECT status + FROM keiro.keiro_read_models + WHERE name = $1 + FOR SHARE + """ + (E.param (E.nonNullable E.text)) + (D.rowMaybe (D.column (D.nonNullable D.text))) + +pruneProjectionDedupBeforeStmt :: Statement UTCTime Int64 +pruneProjectionDedupBeforeStmt = + preparable + """ + DELETE FROM keiro.keiro_projection_dedup + WHERE applied_at < $1 + """ + (E.param (E.nonNullable E.timestamptz)) + D.rowsAffected + +eventIdToUuid :: EventId -> UUID +eventIdToUuid (EventId value) = value diff --git a/src/Keiro/ReadModel.hs b/src/Keiro/ReadModel.hs new file mode 100644 --- /dev/null +++ b/src/Keiro/ReadModel.hs @@ -0,0 +1,366 @@ +{- | Querying the read side, with explicit consistency. + +A 'ReadModel' is a named, versioned SQL projection table plus the query that +reads it. Querying it does more than run SQL: 'runQuery' first verifies the +table's registered schema is current and 'Live' (rejecting a stale or +mid-rebuild model), then honours the requested 'ConsistencyMode' before +running the query in a transaction. + +The consistency modes trade freshness against latency: + +* 'Strong' — capture the store head position at query start and block until + the model's subscription cursor reaches it. +* 'Eventual' — query immediately. Read-your-writes is the projection worker's + responsibility under 'Eventual'. +* 'PositionWait' — block until the model's subscription has caught up to a + target 'GlobalPosition' (typically the position returned by the command + the caller just ran), giving read-your-writes against an asynchronous + projection. 'waitFor' implements the polling loop and times out with + 'ReadModelWaitTimeout'. + +Schema lifecycle (registration, status transitions) lives in +"Keiro.ReadModel.Schema", which is re-exported here. + +Register each model once at projection startup with 'registerReadModel' before +serving queries. Queries fail with 'ReadModelUnregistered' when startup wiring +has not registered the model; they never create registry rows themselves. +-} +module Keiro.ReadModel ( + -- * Definition + ReadModel (..), + qualifiedTableName, + + -- * Consistency + ConsistencyMode (..), + StrongScope (..), + PositionWaitOptions (..), + defaultStrongWaitOptions, + + -- * Querying + runQuery, + runQueryWith, + waitFor, + readSubscriptionPosition, + storeHeadPosition, + categoryHeadPosition, + + -- * Errors + ReadModelError (..), + + -- * Schema lifecycle + module Keiro.ReadModel.Schema, +) +where + +import Control.Concurrent (threadDelay) +import Data.Time.Clock (diffUTCTime) +import Data.Vector qualified as Vector +import Effectful (Eff, IOE, (:>)) +import Hasql.Decoders qualified as D +import Hasql.Encoders qualified as E +import Hasql.Statement (Statement, preparable) +import Keiro.Connection (qualifyTable) +import Keiro.Prelude +import Keiro.ReadModel.Schema +import Keiro.Telemetry (KeiroMetrics, recordProjectionWaitTimeouts) +import Kiroku.Store.Effect (Store) +import Kiroku.Store.Read (readAllBackward) +import Kiroku.Store.Transaction (runTransaction) +import Kiroku.Store.Types (GlobalPosition (..)) +import "hasql-transaction" Hasql.Transaction qualified as Tx +import Prelude qualified + +{- | A queryable read-side projection over a query input @q@ and result @r@. + +* 'name' — logical identity, also the key in the @keiro_read_models@ + registry. +* 'tableName' — the underlying projection table. +* 'schema' — the PostgreSQL schema the read-model /data/ table lives in. The + application qualifies its 'query' SQL against this schema (typically via + 'Keiro.Connection.qualifyTable' or 'qualifiedTableName'); Keiro does not + rewrite 'query'. This is the application's data schema and is entirely + separate from Keiro's own @keiro@ schema, where the @keiro_read_models@ + registry lives. It is deliberately not persisted (see 'ensureReadModel'). +* 'subscriptionName' — the cursor that tracks how far the projection worker + has consumed the event log; consulted by 'PositionWait'. +* 'version' \/ 'shapeHash' — schema identity; a query fails with + 'ReadModelStaleSchema' if the registered values diverge, forcing a rebuild. +* 'defaultConsistency' — the 'ConsistencyMode' used by 'runQuery'. +* 'strongScope' — the event-log head a 'Strong' query waits for. +* 'query' — the SQL read, as a 'Hasql.Transaction.Transaction'. +-} +data ReadModel q r = ReadModel + { name :: !Text + , tableName :: !Text + , schema :: !Text + , subscriptionName :: !Text + , version :: !Int + , shapeHash :: !Text + , defaultConsistency :: !ConsistencyMode + , strongScope :: !StrongScope + , query :: !(q -> Tx.Transaction r) + } + deriving stock (Generic) + +{- | The read model's fully-qualified, double-quoted table reference +@"schema"."table"@, for interpolation into the application's projection SQL. +Equal to @'Keiro.Connection.qualifyTable' ('schema' rm) ('tableName' rm)@. +-} +qualifiedTableName :: ReadModel q r -> Text +qualifiedTableName readModel = + qualifyTable (readModel ^. #schema) (readModel ^. #tableName) + +{- | How fresh a read must be before the query runs. + +'Strong' waits for the model's subscription to reach the store head captured +at query start according to the model's 'strongScope'. It is intended for +asynchronous read models with a worker advancing that subscription cursor; +inline-only models should use 'Eventual' because they have no subscription +worker to advance while waiting. +'PositionWait' blocks until the projection has caught up to a caller-supplied +target log position (or times out). 'Eventual' queries immediately. +-} +data ConsistencyMode + = Strong + | Eventual + | PositionWait !PositionWaitOptions + deriving stock (Generic, Eq, Show) + +{- | Which log head a 'Strong' read must reach. + +'EntireLog' preserves the original behavior and is live only when the model's +subscription observes every event. A category subscription should use +'CategoryHead' with its Kiroku category, so unrelated categories cannot hold +the read behind forever. A model fed by multiple categories should use +'PositionWait' for an explicit write position or 'EntireLog' with a matching +all-stream subscription. + +Kiroku currently does not advance category checkpoints on empty fetches. If it +does so in a future release, category-scoped targets may become unnecessary, +but the explicit model contract remains valid. +-} +data StrongScope + = EntireLog + | CategoryHead !Text + deriving stock (Generic, Eq, Show) + +{- | Parameters for a 'PositionWait' query. + +* 'target' — the 'GlobalPosition' the projection must reach; 'Nothing' + skips waiting entirely. +* 'timeoutMicros' — give up after this long with 'ReadModelWaitTimeout'. +* 'pollMicros' — delay between subscription-position checks. +-} +data PositionWaitOptions = PositionWaitOptions + { target :: !(Maybe GlobalPosition) + , timeoutMicros :: !Int + , pollMicros :: !Int + } + deriving stock (Generic, Eq, Show) + +{- | Default wait settings used by 'Strong': wait up to five seconds, polling +every 10ms, for the store head captured at query start. +-} +defaultStrongWaitOptions :: PositionWaitOptions +defaultStrongWaitOptions = + PositionWaitOptions + { target = Nothing + , timeoutMicros = 5000000 + , pollMicros = 10000 + } + +-- | Why a read-model query could not run. +data ReadModelError + = {- | No registry row exists for the model. Register it once at projection + startup with 'registerReadModel' before serving queries. + -} + ReadModelUnregistered !Text + | {- | The registered schema (version or shape hash) differs from the + model's current definition: name, expected vs. found version, then + expected vs. found shape hash. The model must be rebuilt. + -} + ReadModelStaleSchema !Text !Int !Int !Text !Text + | {- | A 'PositionWait' query timed out: model name, target position, and + the last observed subscription position. + -} + ReadModelWaitTimeout !Text !GlobalPosition !GlobalPosition + | {- | The model is registered but not 'Live' (e.g. rebuilding or + abandoned): name and current status. + -} + ReadModelNotLive !Text !ReadModelStatus + deriving stock (Generic, Eq, Show) + +{- | Query a read model using its 'defaultConsistency'. Validates schema and +liveness first, waits if the mode requires it, then runs the query. +-} +runQuery :: + (IOE :> es, Store :> es) => + Maybe KeiroMetrics -> + ReadModel q r -> + q -> + Eff es (Either ReadModelError r) +runQuery metrics readModel = + runQueryWith metrics (readModel ^. #defaultConsistency) readModel + +{- | Query a read model with an explicit 'ConsistencyMode', overriding its +default. Validates the model's schema and liveness, honours the wait mode, +then runs the query in a transaction. +-} +runQueryWith :: + (IOE :> es, Store :> es) => + Maybe KeiroMetrics -> + ConsistencyMode -> + ReadModel q r -> + q -> + Eff es (Either ReadModelError r) +runQueryWith metrics consistency readModel input = do + schemaCheck <- ensureReadModel readModel + case schemaCheck of + Left err -> pure (Left err) + Right () -> do + waitResult <- waitIfNeeded metrics consistency readModel + case waitResult of + Left err -> pure (Left err) + Right () -> Right <$> runTransaction ((readModel ^. #query) input) + +{- | Block until the model's subscription has advanced to @targetPosition@, +polling at 'pollMicros' intervals. Returns @Right ()@ once caught up, or +'ReadModelWaitTimeout' if 'timeoutMicros' elapses first. +-} +waitFor :: + (IOE :> es, Store :> es) => + Maybe KeiroMetrics -> + PositionWaitOptions -> + ReadModel q r -> + GlobalPosition -> + Eff es (Either ReadModelError ()) +waitFor metrics options readModel targetPosition = do + started <- liftIO getCurrentTime + poll started (GlobalPosition 0) + where + poll started observed = do + current <- readSubscriptionPosition (readModel ^. #subscriptionName) + let observed' = fromMaybe observed current + if observed' >= targetPosition + then pure (Right ()) + else do + now <- liftIO getCurrentTime + let elapsedMicros = + Prelude.floor + (diffUTCTime now started Prelude.* 1000000) + if elapsedMicros >= options ^. #timeoutMicros + then do + -- A genuine give-up: bump keiro.projection.wait.timeouts (no-op + -- under a 'Nothing' handle) before surfacing the timeout. + recordProjectionWaitTimeouts metrics 1 + pure + (Left (ReadModelWaitTimeout (readModel ^. #name) targetPosition observed')) + else do + liftIO (threadDelay (options ^. #pollMicros)) + poll started observed' + +-- Note: the read model's 'schema' field is deliberately NOT persisted here. The +-- registry keys on name/version/shapeHash/status (the model's schema identity); +-- where the application's data table physically lives is a deployment/wiring +-- concern, not part of that identity. See EP-4's Decision Log. +ensureReadModel :: + (Store :> es) => + ReadModel q r -> + Eff es (Either ReadModelError ()) +ensureReadModel readModel = do + found <- lookupReadModel (readModel ^. #name) + pure $ case found of + Just metadata -> validateMetadata readModel metadata + Nothing -> Left (ReadModelUnregistered (readModel ^. #name)) + +validateMetadata :: ReadModel q r -> ReadModelMetadata -> Either ReadModelError () +validateMetadata readModel metadata + | metadata ^. #version /= readModel ^. #version = + stale + | metadata ^. #shapeHash /= readModel ^. #shapeHash = + stale + | metadata ^. #status /= Live = + Left (ReadModelNotLive (readModel ^. #name) (metadata ^. #status)) + | otherwise = + Right () + where + stale = + Left + ( ReadModelStaleSchema + (readModel ^. #name) + (readModel ^. #version) + (metadata ^. #version) + (readModel ^. #shapeHash) + (metadata ^. #shapeHash) + ) + +waitIfNeeded :: + (IOE :> es, Store :> es) => + Maybe KeiroMetrics -> + ConsistencyMode -> + ReadModel q r -> + Eff es (Either ReadModelError ()) +waitIfNeeded metrics Strong readModel = do + target <- case readModel ^. #strongScope of + EntireLog -> storeHeadPosition + CategoryHead category -> categoryHeadPosition category + waitFor metrics (defaultStrongWaitOptions & #target ?~ target) readModel target +waitIfNeeded _ Eventual _ = pure (Right ()) +waitIfNeeded metrics (PositionWait options) readModel = + case options ^. #target of + Nothing -> pure (Right ()) + Just targetPosition -> waitFor metrics options readModel targetPosition + +readSubscriptionPosition :: + (Store :> es) => + Text -> + Eff es (Maybe GlobalPosition) +readSubscriptionPosition subscriptionName = + runTransaction + $ Tx.statement subscriptionName lookupSubscriptionPositionStmt + +lookupSubscriptionPositionStmt :: Statement Text (Maybe GlobalPosition) +lookupSubscriptionPositionStmt = + preparable + """ + SELECT min(last_seen) + FROM subscriptions + WHERE subscription_name = $1 + """ + (E.param (E.nonNullable E.text)) + (D.singleRow (fmap GlobalPosition <$> D.column (D.nullable D.int8))) + +{- | The global position of the most recent event in the @$all@ log, or +@GlobalPosition 0@ when the log is empty. 'readAllBackward' treats +@GlobalPosition 0@ as "after everything", so a limit of 1 returns the head. +-} +storeHeadPosition :: (Store :> es) => Eff es GlobalPosition +storeHeadPosition = do + recent <- readAllBackward (GlobalPosition 0) 1 + pure $ case Vector.toList recent of + (event : _) -> event ^. #globalPosition + [] -> GlobalPosition 0 + +{- | The latest global position originating in a Kiroku category, or +@GlobalPosition 0@ when that category has no events. This deliberately reads +Kiroku's indexed @streams@ and @$all@ membership tables because Kiroku 0.3 does +not export a category-head query. +-} +categoryHeadPosition :: (Store :> es) => Text -> Eff es GlobalPosition +categoryHeadPosition category = + runTransaction + $ Tx.statement category categoryHeadPositionStmt + +categoryHeadPositionStmt :: Statement Text GlobalPosition +categoryHeadPositionStmt = + preparable + """ + SELECT COALESCE(max(se.stream_version), 0) + FROM streams s + JOIN stream_events se + ON se.original_stream_id = s.stream_id + AND se.stream_id = 0 + WHERE s.category = $1 + """ + (E.param (E.nonNullable E.text)) + (D.singleRow (GlobalPosition <$> D.column (D.nonNullable D.int8))) diff --git a/src/Keiro/ReadModel/Rebuild.hs b/src/Keiro/ReadModel/Rebuild.hs new file mode 100644 --- /dev/null +++ b/src/Keiro/ReadModel/Rebuild.hs @@ -0,0 +1,196 @@ +{- | The supported offline read-model rebuild lifecycle. + +Use this checklist rather than composing the low-level status transitions: + +1. Call 'Keiro.ReadModel.Schema.registerReadModel' once at projection startup. + Explicit registration makes misspelled or never-populated models fail with + 'ReadModelUnregistered' instead of appearing healthy. +2. Call 'startRebuild' with every feeding async projection name and the replay + position. It atomically fences live writers, takes queries offline, truncates + the data table, clears the named dedup keys, and resets the subscription + checkpoint, preventing live/replay interleaving and all-deduplicated rebuilds. +3. Replay through 'Keiro.Projection.applyAsyncProjectionUnfenced'. This is the + only apply path allowed to bypass the live-writer fence, while retaining + deduplication inside the designated rebuild. +4. After replay catches up and application-specific verification succeeds, call + 'finishRebuild' with the same projection names and replay position. Its + promotion guard refuses to serve a non-empty-log rebuild that applied no + events. +5. If replay or verification fails, call 'abandonRebuild'. Queries remain + unavailable instead of exposing partial data; repair or restore the table + before beginning another rebuild. + +Normal workers continue to call 'Keiro.Projection.applyAsyncProjection'. Its +registry lock fences them automatically while the model is rebuilding, but they +must not checkpoint an 'Keiro.Projection.AsyncFenced' event. Keiro does not yet +provide a shadow-table or online cutover mechanism; applications that need +zero-downtime rebuilds must build that orchestration above this lifecycle API. +-} +module Keiro.ReadModel.Rebuild ( + RebuildError (..), + startRebuild, + finishRebuild, + rebuild, + promote, + abandonRebuild, +) +where + +import Contravariant.Extras (contrazip2) +import Data.Text.Encoding qualified as TE +import Effectful (Eff, (:>)) +import Hasql.Decoders qualified as D +import Hasql.Encoders qualified as E +import Hasql.Statement (Statement, preparable) +import Keiro.Prelude +import Keiro.ReadModel +import Kiroku.Store.Effect (Store) +import Kiroku.Store.Transaction (runTransaction) +import Kiroku.Store.Types (GlobalPosition (..)) +import "hasql-transaction" Hasql.Transaction qualified as Tx + +-- | Why a rebuild could not be promoted. +data RebuildError + = {- | The model name and current store head when a rebuild started before + existing events but applied none of its feeding projections. + -} + RebuildProducedNoApplies !Text !GlobalPosition + deriving stock (Generic, Eq, Show) + +{- | Atomically take a model offline, truncate its data table, clear the dedup +keys for its feeding async projections, and reset every member of its +subscription to the supplied replay position. + +The registry transition runs first and holds the row lock that +'Keiro.Projection.applyAsyncProjection' uses as its writer fence. PostgreSQL +keeps the table truncate transactional. Kiroku's public checkpoint save is +monotonic, so this helper deliberately resets @subscriptions.last_seen@ +directly inside the same fenced transaction. +-} +startRebuild :: + (Store :> es) => + ReadModel q r -> + [Text] -> + GlobalPosition -> + Eff es ReadModelMetadata +startRebuild readModel projectionNames replayFrom = + runTransaction $ do + metadata <- transitionReadModelTxFor readModel Rebuilding + Tx.sql (TE.encodeUtf8 ("TRUNCATE TABLE " <> qualifiedTableName readModel)) + unless (null projectionNames) $ + Tx.statement projectionNames deleteProjectionDedupStmt + Tx.statement + (readModel ^. #subscriptionName, globalPositionToInt replayFrom) + resetSubscriptionCheckpointStmt + pure metadata + +{- | Promote a completed rebuild in the same transaction as its safety check. + +When async projection names are supplied, a store head beyond @replayFrom@ +requires at least one new dedup row. 'startRebuild' deleted those rows, so their +count is the model-independent number of projection applications during this +rebuild. An empty projection-name list denotes an inline-only model and skips +the guard because no async dedup rows can exist for it. +-} +finishRebuild :: + (Store :> es) => + ReadModel q r -> + [Text] -> + GlobalPosition -> + Eff es (Either RebuildError ReadModelMetadata) +finishRebuild readModel projectionNames replayFrom = + runTransaction $ do + headPosition <- Tx.statement () storeHeadPositionStmt + applyCount <- + if null projectionNames + then pure 0 + else Tx.statement projectionNames countProjectionDedupStmt + if null projectionNames || applyCount > 0 || headPosition <= replayFrom + then Right <$> transitionReadModelTxFor readModel Live + else pure (Left (RebuildProducedNoApplies (readModel ^. #name) headPosition)) + +{- | Low-level status transition only. It does not truncate data, reset dedup +keys or checkpoints, or establish the complete rebuild workflow. Use +'startRebuild' for supported rebuilds. +-} +rebuild :: (Store :> es) => ReadModel q r -> Eff es ReadModelMetadata +rebuild readModel = + markRebuilding + (readModel ^. #name) + (readModel ^. #version) + (readModel ^. #shapeHash) + +{- | Low-level status transition only. It bypasses the empty-rebuild guard. Use +'finishRebuild' to promote a supported rebuild. +-} +promote :: (Store :> es) => ReadModel q r -> Eff es ReadModelMetadata +promote readModel = + markLive + (readModel ^. #name) + (readModel ^. #version) + (readModel ^. #shapeHash) + +-- | Mark a model 'Abandoned', backing out of an in-progress rebuild. +abandonRebuild :: (Store :> es) => ReadModel q r -> Eff es ReadModelMetadata +abandonRebuild readModel = + markAbandoned + (readModel ^. #name) + (readModel ^. #version) + (readModel ^. #shapeHash) + +transitionReadModelTxFor :: ReadModel q r -> ReadModelStatus -> Tx.Transaction ReadModelMetadata +transitionReadModelTxFor readModel status = + transitionReadModelTx + (readModel ^. #name) + (readModel ^. #version) + (readModel ^. #shapeHash) + status + +deleteProjectionDedupStmt :: Statement [Text] () +deleteProjectionDedupStmt = + preparable + """ + DELETE FROM keiro.keiro_projection_dedup + WHERE projection_name = ANY($1) + """ + (E.param (E.nonNullable (E.foldableArray (E.nonNullable E.text)))) + D.noResult + +countProjectionDedupStmt :: Statement [Text] Int64 +countProjectionDedupStmt = + preparable + """ + SELECT count(*) + FROM keiro.keiro_projection_dedup + WHERE projection_name = ANY($1) + """ + (E.param (E.nonNullable (E.foldableArray (E.nonNullable E.text)))) + (D.singleRow (D.column (D.nonNullable D.int8))) + +resetSubscriptionCheckpointStmt :: Statement (Text, Int64) () +resetSubscriptionCheckpointStmt = + preparable + """ + UPDATE subscriptions + SET last_seen = $2, updated_at = now() + WHERE subscription_name = $1 + """ + ( contrazip2 + (E.param (E.nonNullable E.text)) + (E.param (E.nonNullable E.int8)) + ) + D.noResult + +storeHeadPositionStmt :: Statement () GlobalPosition +storeHeadPositionStmt = + preparable + """ + SELECT COALESCE(max(stream_version), 0) + FROM stream_events + WHERE stream_id = 0 + """ + E.noParams + (D.singleRow (GlobalPosition <$> D.column (D.nonNullable D.int8))) + +globalPositionToInt :: GlobalPosition -> Int64 +globalPositionToInt (GlobalPosition position) = position diff --git a/src/Keiro/ReadModel/Schema.hs b/src/Keiro/ReadModel/Schema.hs new file mode 100644 --- /dev/null +++ b/src/Keiro/ReadModel/Schema.hs @@ -0,0 +1,205 @@ +{- | The @keiro_read_models@ registry: schema identity and lifecycle status. + +Every read model explicitly registers a row at projection startup recording its 'version', 'shapeHash', and +'ReadModelStatus'. The registry is what lets 'Keiro.ReadModel.runQuery' +refuse to serve a model whose code-side schema has drifted from the table on +disk, or one that is mid-rebuild. The status transitions ('markRebuilding', +'markLive', 'markAbandoned') drive the rebuild workflow in +"Keiro.ReadModel.Rebuild". + +All operations run as single-statement 'Hasql.Transaction.Transaction's +against the @keiro_read_models@ table; an unrecognized stored status decodes +to 'UnknownStatus' so callers see the raw database value instead of a silent +fallback. +-} +module Keiro.ReadModel.Schema ( + -- * Metadata + ReadModelMetadata (..), + ReadModelStatus (..), + + -- * Registration and lookup + registerReadModel, + lookupReadModel, + + -- * Status transitions + markRebuilding, + markLive, + markAbandoned, + transitionReadModelTx, +) +where + +import Contravariant.Extras (contrazip3, contrazip4) +import Effectful (Eff, (:>)) +import Hasql.Decoders qualified as D +import Hasql.Encoders qualified as E +import Hasql.Statement (Statement, preparable) +import Keiro.Prelude +import Kiroku.Store.Effect (Store) +import Kiroku.Store.Transaction (runTransaction) +import "hasql-transaction" Hasql.Transaction qualified as Tx +import Prelude qualified + +{- | Lifecycle status of a registered read model. + +* 'Live' — current and queryable. +* 'Rebuilding' — being repopulated from the event log; not yet queryable. +* 'Paused' — temporarily not served. +* 'Abandoned' — a rebuild that was given up on. +* 'UnknownStatus' — a database value this library version does not recognize. +-} +data ReadModelStatus + = Live + | Rebuilding + | Paused + | Abandoned + | UnknownStatus !Text + deriving stock (Generic, Eq, Show) + +{- | One row of the @keiro_read_models@ registry: a model's name, schema +identity ('version' and 'shapeHash'), the time it was last (re)built, and +its current 'status'. +-} +data ReadModelMetadata = ReadModelMetadata + { name :: !Text + , version :: !Int + , shapeHash :: !Text + , lastBuiltAt :: !(Maybe UTCTime) + , status :: !ReadModelStatus + } + deriving stock (Generic, Eq, Show) + +{- | Register a read model once at projection startup, inserting a 'Live' row +if none exists. Querying never performs this registration automatically, so +deployments that previously relied on their first query to register must add +this startup call. Idempotent: +an existing registration is returned unchanged (the @version@ and +@shapeHash@ are /not/ overwritten), so a query can compare them and detect +schema drift. +-} +registerReadModel :: (Store :> es) => Text -> Int -> Text -> Eff es ReadModelMetadata +registerReadModel name version shapeHash = + runTransaction + $ Tx.statement + (name, Prelude.fromIntegral version, shapeHash) + registerReadModelStmt + +-- | Look up a read model's registry row by name, if it exists. +lookupReadModel :: (Store :> es) => Text -> Eff es (Maybe ReadModelMetadata) +lookupReadModel name = + runTransaction + $ Tx.statement name lookupReadModelStmt + +{- | Upsert the registry row to 'Rebuilding' at the given schema identity. +Marks the model as being repopulated so queries stop serving it until +'markLive'. +-} +markRebuilding :: (Store :> es) => Text -> Int -> Text -> Eff es ReadModelMetadata +markRebuilding name version shapeHash = + runTransaction $ transitionReadModelTx name version shapeHash Rebuilding + +{- | Upsert the registry row to 'Live' at the given schema identity, stamping +@last_built_at@. Makes the model queryable again after a rebuild. +-} +markLive :: (Store :> es) => Text -> Int -> Text -> Eff es ReadModelMetadata +markLive name version shapeHash = + runTransaction $ transitionReadModelTx name version shapeHash Live + +{- | Upsert the registry row to 'Abandoned' at the given schema identity, +recording that a rebuild was given up on. +-} +markAbandoned :: (Store :> es) => Text -> Int -> Text -> Eff es ReadModelMetadata +markAbandoned name version shapeHash = + runTransaction $ transitionReadModelTx name version shapeHash Abandoned + +{- | Transaction-composable form of a registry status transition. Rebuild +orchestration uses this form so the status row lock, table reset, dedup reset, +and checkpoint reset share one database transaction. +-} +transitionReadModelTx :: Text -> Int -> Text -> ReadModelStatus -> Tx.Transaction ReadModelMetadata +transitionReadModelTx name version shapeHash status = + Tx.statement + (name, Prelude.fromIntegral version, shapeHash, statusToText status) + transitionReadModelStmt + +registerReadModelStmt :: Statement (Text, Int64, Text) ReadModelMetadata +registerReadModelStmt = + preparable + """ + INSERT INTO keiro.keiro_read_models (name, version, shape_hash, status, last_built_at) + VALUES ($1, $2, $3, 'live', now()) + ON CONFLICT (name) DO UPDATE + SET name = EXCLUDED.name + RETURNING name, version, shape_hash, last_built_at, status + """ + ( contrazip3 + (E.param (E.nonNullable E.text)) + (E.param (E.nonNullable E.int8)) + (E.param (E.nonNullable E.text)) + ) + readModelMetadataSingle + +lookupReadModelStmt :: Statement Text (Maybe ReadModelMetadata) +lookupReadModelStmt = + preparable + """ + SELECT name, version, shape_hash, last_built_at, status + FROM keiro.keiro_read_models + WHERE name = $1 + """ + (E.param (E.nonNullable E.text)) + (D.rowMaybe readModelMetadataDecoder) + +transitionReadModelStmt :: Statement (Text, Int64, Text, Text) ReadModelMetadata +transitionReadModelStmt = + preparable + """ + INSERT INTO keiro.keiro_read_models (name, version, shape_hash, status, last_built_at, updated_at) + VALUES ($1, $2, $3, $4, now(), now()) + ON CONFLICT (name) DO UPDATE + SET version = EXCLUDED.version, + shape_hash = EXCLUDED.shape_hash, + status = EXCLUDED.status, + last_built_at = CASE + WHEN EXCLUDED.status = 'live' THEN now() + ELSE keiro_read_models.last_built_at + END, + updated_at = now() + RETURNING name, version, shape_hash, last_built_at, status + """ + ( contrazip4 + (E.param (E.nonNullable E.text)) + (E.param (E.nonNullable E.int8)) + (E.param (E.nonNullable E.text)) + (E.param (E.nonNullable E.text)) + ) + readModelMetadataSingle + +readModelMetadataSingle :: D.Result ReadModelMetadata +readModelMetadataSingle = + D.singleRow readModelMetadataDecoder + +readModelMetadataDecoder :: D.Row ReadModelMetadata +readModelMetadataDecoder = + ReadModelMetadata + <$> D.column (D.nonNullable D.text) + <*> (Prelude.fromIntegral <$> D.column (D.nonNullable D.int8)) + <*> D.column (D.nonNullable D.text) + <*> D.column (D.nullable D.timestamptz) + <*> (statusFromText <$> D.column (D.nonNullable D.text)) + +statusToText :: ReadModelStatus -> Text +statusToText = \case + Live -> "live" + Rebuilding -> "rebuilding" + Paused -> "paused" + Abandoned -> "abandoned" + UnknownStatus raw -> raw + +statusFromText :: Text -> ReadModelStatus +statusFromText = \case + "live" -> Live + "rebuilding" -> Rebuilding + "paused" -> Paused + "abandoned" -> Abandoned + raw -> UnknownStatus raw diff --git a/src/Keiro/Router.hs b/src/Keiro/Router.hs new file mode 100644 --- /dev/null +++ b/src/Keiro/Router.hs @@ -0,0 +1,425 @@ +{- | Stateless, content-based routing of events to commands. + +A 'Router' is the stateless sibling of +'Keiro.ProcessManager.ProcessManager': for each incoming event it resolves +a data-dependent set of target streams /effectfully/ (typically via a +read-model query) and dispatches one command to each. Dispatch is +idempotent per resolved target identity: every command is appended under a +target-name-keyed deterministic id, and store-level duplicate rejections are +confirmed against that target before becoming a benign +'PMCommandDuplicate'. Redelivery therefore deduplicates every target resolved +again, regardless of target order. Because resolution is effectful, the target +set may drift between attempts; dispatches accumulate as the union of those +attempts, so callers that require one exact set must keep resolution stable for +a source event. + +Use 'runRouterOnce' to dispatch a single event, or 'runRouterWorker' to run +the router as a live subscription draining a Shibuya adapter. Its retry and +source-event dead-letter contract is the same bounded Kiroku contract described +by "Keiro.ProcessManager": five total deliveries by default, followed by a +@kiroku.dead_letters@ write and atomic checkpoint advance. + +A router's 'key' can join events from different source streams just as a +process manager's @correlate@ function can. The same ordering rule applies: +same-stream order is preserved, but different streams have no relative +business-order guarantee and may run concurrently under sharding. Keep routed +logic order-insensitive; see "Keiro.ProcessManager" for the worked example. +Each resolved target command (with its inline projections) commits in its own +transaction, so fan-out is idempotent rather than all-target atomic. +-} +module Keiro.Router ( + -- * Definition + Router (..), + RouterResult (..), + + -- * Idempotency + deterministicRouterCommandId, + + -- * Running + runRouterOnce, + runRouterWorkerWith, + runRouterWorker, +) +where + +import Data.ByteString qualified as ByteString +import Data.ByteString.Char8 qualified as ByteString.Char8 +import Data.Coerce (coerce) +import Data.Map.Strict qualified as Map +import Data.Text qualified as Text +import Data.Text.Encoding qualified as Text.Encoding +import Data.Traversable (mapAccumL) +import Data.UUID qualified as UUID +import Data.UUID.V5 qualified as UUID.V5 +import Effectful (Eff, IOE, (:>)) +import Effectful.Error.Static (Error, tryError) +import GHC.Stack (HasCallStack) +import Keiki.Core (BoolAlg, RegFile) +import Keiro.Command (CommandError (..), RunCommandOptions) +import Keiro.DeadLetter (DispatcherKind (..)) +import Keiro.EventStream (EventStream) +import Keiro.EventStream.Validate (ValidatedEventStream, unvalidated) +import Keiro.Prelude +import Keiro.ProcessManager ( + DispatchFailure (..), + PMCommand (..), + PMCommandResult (..), + PoisonPolicy (..), + WorkerOptions (..), + ackForCommandError, + confirmBenignDuplicate, + decideForFailures, + defaultWorkerOptions, + deterministicCommandId, + eventAlreadyIn, + ) +import Keiro.Projection (InlineProjection, runCommandWithProjections) +import Keiro.Stream (Stream) +import Keiro.Telemetry (recordDispatchDuplicate, recordDispatchFailed, recordDispatchPoison) +import Kiroku.Store.Effect (Store) +import Kiroku.Store.Effect.Resource (KirokuStoreResource) +import Kiroku.Store.Error (StoreError (..)) +import Kiroku.Store.Types (EventId (..), RecordedEvent, StreamName (..)) +import Shibuya.Adapter (Adapter (..)) +import Shibuya.Core.Ack (AckDecision (..), DeadLetterReason (..), HaltReason (..)) +import Shibuya.Core.AckHandle (AckHandle (..)) +import Shibuya.Core.Ingested (Ingested (..)) +import Shibuya.Core.Types (Attempt (..), Envelope (..)) +import Streamly.Data.Fold qualified as Fold +import Streamly.Data.Stream qualified as Streamly +import Prelude (filter, fromIntegral, length, snd, zip, (+)) + +{- | A stateless, content-based router (in the Enterprise Integration Patterns +sense): for each incoming event it resolves a data-dependent set of target +streams /effectfully/ and dispatches one command to each. + +This is the stateless counterpart of 'Keiro.ProcessManager.ProcessManager'. It +has no manager state stream, no @correlate@, and no self-directed command. Its +sole new capability over the process manager is that target resolution runs in +@Eff es@ — typically a read-model query via 'Keiro.ReadModel.runQuery' — so the +fan-out set can be /looked up/ rather than computed purely from the event. + +Dispatch is idempotent by construction: each target command is appended under a +deterministic identifier derived from @(name, key input, source event id, +resolved target stream name, occurrence)@ (see +'deterministicRouterCommandId'), pre-checked with 'eventAlreadyIn', and the +store's @DuplicateEvent@ rejection is confirmed against the target stream +before it is treated as benign. A redelivery deduplicates every target it +resolves again even if target order or membership changed. A target resolved +only on an earlier attempt keeps its immutable dispatch, and a newly resolved +target is dispatched on the later attempt; the cumulative set is therefore the +union of attempt outputs. Keep 'resolve' stable for a source event when the +exact recipient set matters. + +Each dispatch also runs 'targetProjections' for the target aggregate in the same +append transaction. The function receives the concrete target stream so callers can +build projections closed over stream-local keys. Return @[]@ to preserve +append-only dispatch. +-} +data Router input targetPhi targetRs targetState targetCi targetCo es = Router + { name :: !Text + -- ^ Stable identifier; part of every dispatched command's deterministic id. + , key :: !(input -> Text) + -- ^ Correlation string for the source event (e.g. the transaction id). + , resolve :: !(input -> Eff es [PMCommand targetCi]) + {- ^ The effectful seam: compute the data-dependent target set, typically + @runQuery readModel q@. + -} + , targetEventStream :: !(ValidatedEventStream targetPhi targetRs targetState targetCi targetCo) + -- ^ The aggregate every resolved command is dispatched to. + , targetProjections :: !(Stream targetCi -> [InlineProjection targetCo]) + {- ^ Inline projections for the target aggregate, run in the same transaction + as each dispatched command's append. Return @[]@ for append-only dispatch. + -} + } + deriving stock (Generic) + +{- | The outcome of a single 'runRouterOnce' invocation: one +'PMCommandResult' per resolved target, in resolution order. + +Unlike 'Keiro.ProcessManager.ProcessManagerResult' there is no manager-state +result, because a router has no state stream. A failed dispatch surfaces as a +'PMCommandFailed' element rather than an outer 'Either'. +-} +newtype RouterResult target = RouterResult + { commandResults :: [PMCommandResult target] + } + deriving stock (Generic, Eq, Show) + +{- | Derive a stable, collision-resistant 'EventId' for a router dispatch from +@(router name, key input, source event id, resolved target stream name, +occurrence)@ via a v5 UUID. + +Unlike 'Keiro.ProcessManager.deterministicCommandId' (which the process manager +still uses, soundly, because its command list is a pure function of the input), +the router keys the id by the target's identity rather than its position in the +resolved list: 'resolve' is effectful, so a redelivery may see the same targets +in a different order or a drifted set, and a positional id would then point at +the wrong target. The @occurrence@ is the index among commands in the same +resolve batch that address the same target stream (0 for the first), so +resolving the same target twice in one batch still yields distinct ids. + +The v5 name encodes every text field as length-prefixed UTF-8. This avoids both +delimiter ambiguity when names contain colons and character truncation for +non-ASCII names. +-} +deterministicRouterCommandId :: Text -> Text -> EventId -> StreamName -> Int -> EventId +deterministicRouterCommandId routerName correlationId sourceEventId targetStreamName occurrence = + EventId + $ UUID.V5.generateNamed UUID.V5.namespaceURL + $ ByteString.unpack + $ ByteString.concat + $ fmap + encodeField + [ "keiro" + , "router" + , routerName + , correlationId + , UUID.toText (coerce sourceEventId) + , coerce targetStreamName + , Text.pack (show occurrence) + ] + where + encodeField field = + let bytes = Text.Encoding.encodeUtf8 field + in ByteString.concat + [ ByteString.Char8.pack (show (ByteString.length bytes)) + , ByteString.singleton 58 + , bytes + ] + +{- | Resolve the targets for one source event, then dispatch one command per +target with crash-safe, target-identity idempotency. + +Unlike 'Keiro.ProcessManager.runProcessManagerOnce', whose pure command list +can safely use positional ids, a router derives each id from the resolved +target stream name and its same-stream occurrence. It skips ids already in the +target stream, otherwise runs 'Keiro.Projection.runCommandWithProjections', and +folds a @DuplicateEvent@ rejection only after confirming the attempted id is in +that target stream. + +Returns 'RouterResult' directly (no outer @Either CommandError@) because — unlike +the process manager — there is no manager-state append that can fail before +dispatch. +-} +runRouterOnce :: + forall input targetPhi targetRs targetState targetCi targetCo es. + ( HasCallStack + , IOE :> es + , Store :> es + , Error StoreError :> es + , KirokuStoreResource :> es + , BoolAlg targetPhi (RegFile targetRs, targetCi) + , Eq targetCo + ) => + RunCommandOptions -> + Router input targetPhi targetRs targetState targetCi targetCo es -> + RecordedEvent -> + input -> + Eff es (RouterResult (EventStream targetPhi targetRs targetState targetCi targetCo)) +runRouterOnce options router sourceEvent input = do + let correlationId = (router ^. #key) input + commands <- (router ^. #resolve) input + let named = + [ (streamNameOf command, command) + | command <- commands + ] + annotated = snd (mapAccumL occurrenceStep Map.empty (zip [0 ..] named)) + occurrenceStep seen (legacyIndex, (targetStreamName, command)) = + let occurrence = Map.findWithDefault 0 targetStreamName seen + in ( Map.insert targetStreamName (occurrence + 1) seen + , (legacyIndex, occurrence, targetStreamName, command) + ) + results <- + traverse + (dispatchCommand correlationId (sourceEvent ^. #eventId)) + annotated + pure (RouterResult results) + where + streamNameOf command = + ((unvalidated (router ^. #targetEventStream)) ^. #resolveStreamName) + (retarget (command ^. #target)) + + dispatchCommand correlationId sourceEventId (legacyIndex, occurrence, targetStreamName, command) = do + let commandId = + deterministicRouterCommandId + (router ^. #name) + correlationId + sourceEventId + targetStreamName + occurrence + -- Transition: dispatches written by keiro versions that derived + -- positional ids must still dedup across the upgrade. Remove in a + -- later release after the compatibility window closes. + legacyCommandId = + deterministicCommandId + (router ^. #name) + correlationId + sourceEventId + legacyIndex + targetOptions = options & #eventIds .~ [commandId] + targetEventStream = router ^. #targetEventStream + targetStream = retarget (command ^. #target) + commandAlreadyProcessed <- eventAlreadyIn options targetStreamName commandId + legacyAlreadyProcessed <- + if commandAlreadyProcessed + then pure False + else eventAlreadyIn options targetStreamName legacyCommandId + if commandAlreadyProcessed + then pure (PMCommandDuplicate commandId) + else + if legacyAlreadyProcessed + then pure (PMCommandDuplicate legacyCommandId) + else do + outcome <- + runCommandWithProjections + targetOptions + targetEventStream + targetStream + (command ^. #command) + ((router ^. #targetProjections) (command ^. #target)) + case outcome of + Right result -> pure (PMCommandAppended result) + Left err -> do + benign <- confirmBenignDuplicate targetStreamName commandId err + pure $ if benign then PMCommandDuplicate commandId else PMCommandFailed targetStreamName err + + retarget :: Stream targetCi -> Stream (EventStream targetPhi targetRs targetState targetCi targetCo) + retarget = coerce + +{- | Run a 'Router' as a live subscription over a Shibuya 'Adapter'. + +Mirrors 'Keiro.ProcessManager.runProcessManagerWorker': it drains the adapter's +message stream, decoding each message to a @(RecordedEvent, input)@ pair and +dispatching it through 'runRouterOnce'. + +Ack policy (see this plan's Decision Log): + + * a message that fails to decode follows the configured 'PoisonPolicy' + (default: 'AckHalt' @HaltFatal@); + * otherwise, after dispatch, if every 'PMCommandResult' is + 'PMCommandAppended' or 'PMCommandDuplicate' the message finalizes 'AckOk'; + * if any dispatch is 'PMCommandFailed', transient failures finalize + 'AckRetry', systemic deterministic failures finalize @AckHalt + (HaltFatal …)@, and rejection-class failures follow + 'RejectedCommandPolicy'. + +Benign domain rejections (a target aggregate refusing a "check" command because +no edge matches) must be modeled as /total/ transitions in the keiki transducer +(an ε-complement self-loop) so they never surface as 'PMCommandFailed' and +therefore never wedge the worker. When the rejection is genuinely +data-dependent, 'RejectedDeadLetter' persists a queryable +"Keiro.DeadLetter.DispatchDeadLetter" and acknowledges the source event; +'RejectedSkip' acknowledges and records only the metric. 'RejectedHalt' remains +the default. + +The worker invokes each ingested message's 'Shibuya.Core.AckHandle.AckHandle' +@finalize@ exactly once with the decision, so the decision reaches the adapter. +Use 'runRouterWorkerWith' to override poison-message handling, rejected-command +handling, transient retry delay, or dispatch metrics. On a Kiroku-backed +adapter, 'AckRetry' remains bounded by the subscription @RetryPolicy@ (five +total deliveries by default). Exhaustion records the source event in +@kiroku.dead_letters@ with reason kind @max_attempts_exceeded@ and advances the +checkpoint. @KirokuAdapterConfig@ does not currently expose @retryPolicy@; +install 'Keiro.Telemetry.kirokuEventBridge' on Kiroku's @eventHandler@ to observe +the terminal event. The configurable sharded path forwards +@ShardedWorkerOptions.retryPolicy@ through the same Kiroku ladder; see +"Keiro.Subscription.Shard.Worker". +-} +runRouterWorker :: + forall msg input targetPhi targetRs targetState targetCi targetCo es. + ( HasCallStack + , IOE :> es + , Store :> es + , Error StoreError :> es + , KirokuStoreResource :> es + , BoolAlg targetPhi (RegFile targetRs, targetCi) + , Eq targetCo + ) => + RunCommandOptions -> + Router input targetPhi targetRs targetState targetCi targetCo es -> + Adapter es msg -> + (msg -> Maybe (RecordedEvent, input)) -> + Eff es () +runRouterWorker = + runRouterWorkerWith defaultWorkerOptions + +runRouterWorkerWith :: + forall msg input targetPhi targetRs targetState targetCi targetCo es. + ( HasCallStack + , IOE :> es + , Store :> es + , Error StoreError :> es + , KirokuStoreResource :> es + , BoolAlg targetPhi (RegFile targetRs, targetCi) + , Eq targetCo + ) => + WorkerOptions es msg -> + RunCommandOptions -> + Router input targetPhi targetRs targetState targetCi targetCo es -> + Adapter es msg -> + (msg -> Maybe (RecordedEvent, input)) -> + Eff es () +runRouterWorkerWith workerOptions options router Adapter{source = adapterSource} decodeMessage = + Streamly.fold Fold.drain + $ Streamly.mapM handleIngested adapterSource + where + handleIngested :: Ingested es msg -> Eff es AckDecision + handleIngested Ingested{envelope = env@Envelope{payload = message}, ack = AckHandle finalizeAck} = do + decision <- case decodeMessage message of + Nothing -> decideForPoison "router worker could not decode message" env + Just (recorded, input) -> do + let correlationId = (router ^. #key) input + attemptCount = envelopeAttemptCount env + outcome <- tryError @StoreError (runRouterOnce options router recorded input) + case outcome of + Left (_, storeErr) -> do + recordDispatchFailed (workerOptions ^. #metrics) 1 + pure (ackForCommandError (workerOptions ^. #transientRetryDelay) (StoreFailed storeErr)) + Right (RouterResult results) -> ackDecisionFor recorded correlationId attemptCount results + finalizeAck decision + pure decision + + ackDecisionFor :: RecordedEvent -> Text -> Int -> [PMCommandResult target] -> Eff es AckDecision + ackDecisionFor sourceEvent correlationId attemptCount results = do + let duplicateCount = commandDuplicateCount results + failures = + [ DispatchFailure emitIndex targetStreamName err + | (emitIndex, PMCommandFailed targetStreamName err) <- zip [0 ..] results + ] + recordDispatchDuplicate (workerOptions ^. #metrics) duplicateCount + recordDispatchFailed (workerOptions ^. #metrics) (fromIntegral (length failures)) + decideForFailures + workerOptions + DispatcherRouter + (router ^. #name) + correlationId + sourceEvent + attemptCount + failures + + commandDuplicateCount :: [PMCommandResult target] -> Int64 + commandDuplicateCount = + fromIntegral . length . filter isDuplicateResult + where + isDuplicateResult = \case + PMCommandDuplicate{} -> True + _ -> False + + decideForPoison :: Text -> Envelope msg -> Eff es AckDecision + decideForPoison reason env = do + recordDispatchPoison (workerOptions ^. #metrics) 1 + case workerOptions ^. #poisonPolicy of + PoisonHalt -> pure (AckHalt (HaltFatal reason)) + PoisonSkip callback -> do + callback env + pure AckOk + PoisonDeadLetter callback -> do + callback env + pure (AckDeadLetter (InvalidPayload reason)) + + envelopeAttemptCount :: Envelope msg -> Int + envelopeAttemptCount env = + case env ^. #attempt of + Nothing -> 1 + Just (Attempt attempt) -> fromIntegral attempt + 1 diff --git a/src/Keiro/Snapshot.hs b/src/Keiro/Snapshot.hs new file mode 100644 --- /dev/null +++ b/src/Keiro/Snapshot.hs @@ -0,0 +1,168 @@ +{- | Snapshots: skipping replay by persisting folded aggregate state. + +A snapshot stores an aggregate's @(state, registers)@ at a known stream +version so hydration can start there instead of replaying the whole event +log. 'hydrateWithSnapshot' loads the latest compatible snapshot for a +stream (returning a 'SnapshotSeed' the command runner replays /forward/ +from), and 'writeSnapshot' persists one after an append when the stream's +'Keiro.EventStream.SnapshotPolicy' fires. + +Compatibility is gated by the version and register-file shape hash of the +'StateCodec': a snapshot is only loaded when both match the current codec, so a +change to the snapshot encoding or to the register layout transparently +falls back to a full replay rather than decoding stale bytes. The JSON +encoding lives in "Keiro.Snapshot.Codec" and the SQL storage in +"Keiro.Snapshot.Schema", both re-exported here. + +Snapshot version non-regression applies only while the codec version and shape +hash stay the same. A writer with either discriminant changed may replace a +higher-version row, allowing codec rollback to recover. In a mixed-version +deployment incompatible writers can therefore thrash the one row per stream +and repeatedly force full replay; this affects performance, not correctness. +-} +module Keiro.Snapshot ( + -- * Hydration seed + SnapshotSeed (..), + SnapshotMissReason (..), + SnapshotLookup (..), + lookupSnapshotSeed, + hydrateWithSnapshot, + encodeSnapshotStrict, + writeSnapshotEncoded, + writeSnapshot, + + -- * State codec and storage + module Keiro.Snapshot.Codec, + module Keiro.Snapshot.Schema, +) +where + +import Control.DeepSeq (force) +import Control.Exception (ErrorCall, evaluate, try) +import Effectful (Eff, (:>)) +import Keiki.Core (RegFile) +import Keiro.EventStream (StateCodec) +import Keiro.Prelude +import Keiro.Snapshot.Codec +import Keiro.Snapshot.Schema +import Kiroku.Store.Effect (Store) +import Kiroku.Store.Read (lookupStreamId) +import Kiroku.Store.Types (StreamId, StreamName, StreamVersion) + +{- | A decoded snapshot the command runner replays forward from: the folded +'state' and 'registers' as of 'streamVersion'. Hydration reads only the +events after 'streamVersion' instead of the entire stream. +-} +data SnapshotSeed rs s = SnapshotSeed + { state :: !s + , registers :: !(RegFile rs) + , streamVersion :: !StreamVersion + } + deriving stock (Generic) + +-- | Why a snapshot lookup produced no usable hydration seed. +data SnapshotMissReason + = SnapshotNoStream + | SnapshotNotFound + | SnapshotDecodeFailed !Text + deriving stock (Eq, Show, Generic) + +-- | The observable result of looking up and decoding an aggregate snapshot. +data SnapshotLookup rs s + = SnapshotUnavailable !SnapshotMissReason + | SnapshotHit !(SnapshotSeed rs s) + deriving stock (Generic) + +{- | Look up the latest compatible snapshot and retain the reason when no +usable seed exists. A matching row that fails to decode is distinguished from +a missing stream or row so callers can report the persistent fallback. +-} +lookupSnapshotSeed :: + (Store :> es) => + StreamName -> + StateCodec (s, RegFile rs) -> + Eff es (SnapshotLookup rs s) +lookupSnapshotSeed streamName codec = do + streamId <- lookupStreamId streamName + case streamId of + Nothing -> pure (SnapshotUnavailable SnapshotNoStream) + Just foundStreamId -> do + row <- lookupSnapshot foundStreamId (codec ^. #stateCodecVersion) (codec ^. #shapeHash) + pure $ case row of + Nothing -> SnapshotUnavailable SnapshotNotFound + Just snapshot -> + case (codec ^. #decode) (snapshot ^. #state) of + Left message -> SnapshotUnavailable (SnapshotDecodeFailed message) + Right (state, registers) -> + SnapshotHit + SnapshotSeed + { state = state + , registers = registers + , streamVersion = snapshot ^. #streamVersion + } + +{- | Load the latest snapshot compatible with @codec@ for the named stream. + +Returns 'Nothing' — meaning "replay from the beginning" — when the stream +has no id yet, has no snapshot at the codec's version and shape hash, or has +a snapshot whose bytes fail to decode. Decode failure is treated as a benign +miss rather than an error, so a corrupt or stale snapshot never blocks +hydration. +-} +hydrateWithSnapshot :: + (Store :> es) => + StreamName -> + StateCodec (s, RegFile rs) -> + Eff es (Maybe (SnapshotSeed rs s)) +hydrateWithSnapshot streamName codec = do + lookupSnapshotSeed streamName codec <&> \case + SnapshotUnavailable _ -> Nothing + SnapshotHit seed -> Just seed + +{- | Strictly encode @state@ with @codec@, forcing the complete JSON value and +returning an 'ErrorCall' raised by a partial encoder or an uninitialized keiki +register. Other exception types deliberately remain visible to the caller. +-} +encodeSnapshotStrict :: StateCodec state -> state -> IO (Either ErrorCall Value) +encodeSnapshotStrict codec state = + try @ErrorCall (evaluate (force ((codec ^. #encode) state))) + +{- | Upsert a JSON value that has already been encoded and forced. Keeping this +separate from 'writeSnapshot' lets post-commit callers prove encoding is safe +before they touch the store. For a fixed codec version and shape hash, stale +versions are ignored. A different codec version or shape hash may replace a +higher-version row to permit codec rollback; see the module header. +-} +writeSnapshotEncoded :: + (Store :> es) => + StreamId -> + StreamVersion -> + StateCodec state -> + Value -> + Eff es () +writeSnapshotEncoded streamId streamVersion codec encoded = + writeSnapshotRow + SnapshotWrite + { streamId = streamId + , streamVersion = streamVersion + , state = encoded + , stateCodecVersion = codec ^. #stateCodecVersion + , regfileShapeHash = codec ^. #shapeHash + } + +{- | Encode @state@ with @codec@ and upsert it as the snapshot for the given +stream at @streamVersion@. This compatibility helper preserves the historical +lazy encoding behavior; post-commit advisory paths should call +'encodeSnapshotStrict' first and pass the result to 'writeSnapshotEncoded'. For +a fixed codec version and shape hash stale writes are ignored, while an +incompatible codec may replace a newer row to permit rollback. +-} +writeSnapshot :: + (Store :> es) => + StreamId -> + StreamVersion -> + StateCodec state -> + state -> + Eff es () +writeSnapshot streamId streamVersion codec state = + writeSnapshotEncoded streamId streamVersion codec ((codec ^. #encode) state) diff --git a/src/Keiro/Snapshot/Codec.hs b/src/Keiro/Snapshot/Codec.hs new file mode 100644 --- /dev/null +++ b/src/Keiro/Snapshot/Codec.hs @@ -0,0 +1,69 @@ +{- | The default JSON encoding for aggregate snapshots. + +'defaultStateCodec' builds a 'StateCodec' for the @(state, registers)@ pair +of a keiki machine, serializing it as a JSON object @{ "state": …, +"registers": … }@. The state half uses its 'ToJSON' \/ 'FromJSON' +instances; the register half uses keiki's register-file JSON encoding. The +codec's 'shapeHash' is derived from the register-file /shape/, so any change +to the register layout changes the hash and transparently invalidates older +snapshots (see "Keiro.Snapshot"). + +Pass your own version number to bump it explicitly when the state encoding +changes in a way the shape hash does not capture. +-} +module Keiro.Snapshot.Codec ( + defaultStateCodec, +) +where + +import Data.Aeson (Result (..), object, withObject, (.:)) +import Data.Aeson qualified as Aeson +import Data.Aeson.Types (parseEither) +import Data.Text qualified as Text +import Keiki.Codec.JSON (RegFileToJSON, regFileFromJSON, regFileToJSON) +import Keiki.Core (RegFile) +import Keiki.Shape (KnownRegFileShape, regFileShapeHash) +import Keiro.EventStream (StateCodec (..)) +import Keiro.Prelude + +{- | A 'StateCodec' that serializes a @(state, registers)@ pair to a JSON +object, tagging it with the supplied codec version and a shape hash derived +from the register-file layout. +-} +defaultStateCodec :: + forall rs s. + (FromJSON s, KnownRegFileShape rs, RegFileToJSON rs, ToJSON s) => + Int -> + StateCodec (s, RegFile rs) +defaultStateCodec version = + StateCodec + { stateCodecVersion = version + , shapeHash = regFileShapeHash (Proxy @rs) + , encode = \(state, registers) -> + object + [ "state" Aeson..= state + , "registers" Aeson..= regFileToJSON registers + ] + , decode = decodeSnapshotValue + } + +decodeSnapshotValue :: + forall rs s. + (FromJSON s, RegFileToJSON rs) => + Value -> + Either Text (s, RegFile rs) +decodeSnapshotValue value = + case parseEither parser value of + Left message -> Left (Text.pack message) + Right pair -> Right pair + where + parser = withObject "Keiro snapshot" $ \objectValue -> do + stateValue <- objectValue .: "state" + registerValue <- objectValue .: "registers" + state <- case Aeson.fromJSON stateValue of + Error message -> fail ("state: " <> message) + Success decoded -> pure decoded + registers <- case regFileFromJSON @rs registerValue of + Left message -> fail ("registers: " <> message) + Right decoded -> pure decoded + pure (state, registers) diff --git a/src/Keiro/Snapshot/Schema.hs b/src/Keiro/Snapshot/Schema.hs new file mode 100644 --- /dev/null +++ b/src/Keiro/Snapshot/Schema.hs @@ -0,0 +1,173 @@ +{- | The @keiro_snapshots@ table: persistence for aggregate snapshots. + +One row per stream holds the latest snapshot of its folded state as JSONB, +tagged with the 'stateCodecVersion' and 'regfileShapeHash' that produced it. +'lookupSnapshot' fetches the newest row matching a given version and shape +hash (so incompatible snapshots are simply not found). Within one codec +version and shape hash, 'writeSnapshotRow' keeps only the highest stream +version, so a late or out-of-order write cannot regress the snapshot. + +A write with a /different/ codec version or shape hash deliberately replaces +the row even at a lower stream version. This lets a rolled-back deployment +reclaim the single snapshot slot instead of being locked out by a newer codec +forever. During a mixed-version deployment, however, writers with incompatible +codecs can thrash that row and each side will miss the other's snapshot. The +cost is repeated full replay, never incorrect state: the event log remains the +source of truth. + +This module is the storage layer beneath "Keiro.Snapshot"; callers normally +go through 'Keiro.Snapshot.hydrateWithSnapshot' and +'Keiro.Snapshot.writeSnapshot' rather than these statements directly. +-} +module Keiro.Snapshot.Schema ( + -- * Rows + SnapshotRow (..), + SnapshotWrite (..), + + -- * Storage + lookupSnapshot, + writeSnapshotRow, +) +where + +import Contravariant.Extras (contrazip3, contrazip5) +import Effectful (Eff, (:>)) +import Hasql.Decoders qualified as D +import Hasql.Encoders qualified as E +import Hasql.Statement (Statement, preparable) +import Keiro.Prelude +import Kiroku.Store.Effect (Store) +import Kiroku.Store.Transaction (runTransaction) +import Kiroku.Store.Types (StreamId (..), StreamVersion (..)) +import "hasql-transaction" Hasql.Transaction qualified as Tx +import Prelude qualified + +{- | A snapshot row as read back from @keiro_snapshots@: the stored 'state' +JSON, the 'streamVersion' it captures, the 'stateCodecVersion' and +'regfileShapeHash' that gate compatibility, and the create/update +timestamps. +-} +data SnapshotRow = SnapshotRow + { streamId :: !StreamId + , streamVersion :: !StreamVersion + , state :: !Value + , stateCodecVersion :: !Int + , regfileShapeHash :: !Text + , createdAt :: !UTCTime + , updatedAt :: !UTCTime + } + deriving stock (Generic, Eq, Show) + +{- | The fields needed to write a snapshot — 'SnapshotRow' minus the +database-managed timestamps. +-} +data SnapshotWrite = SnapshotWrite + { streamId :: !StreamId + , streamVersion :: !StreamVersion + , state :: !Value + , stateCodecVersion :: !Int + , regfileShapeHash :: !Text + } + deriving stock (Generic, Eq, Show) + +{- | Fetch the latest snapshot for a stream that matches the given codec +version and register-file shape hash. Returns 'Nothing' when no compatible +snapshot exists, so an incompatible one is treated as absent. +-} +lookupSnapshot :: + (Store :> es) => + StreamId -> + Int -> + Text -> + Eff es (Maybe SnapshotRow) +lookupSnapshot streamId version shapeHash = + runTransaction + $ Tx.statement + (streamIdToInt streamId, Prelude.fromIntegral version, shapeHash) + lookupSnapshotStmt + +{- | Upsert a snapshot row for its stream. For the same codec version and shape +hash, the write only takes effect when its 'streamVersion' is at least the +stored one. An incompatible codec version or shape hash replaces the row even +at a lower version so codec rollback can make progress; see the module header +for the mixed-deployment performance caveat. +-} +writeSnapshotRow :: + (Store :> es) => + SnapshotWrite -> + Eff es () +writeSnapshotRow snapshot = + runTransaction + $ Tx.statement (snapshotWriteParams snapshot) writeSnapshotStmt + +lookupSnapshotStmt :: Statement (Int64, Int64, Text) (Maybe SnapshotRow) +lookupSnapshotStmt = + preparable + """ + SELECT stream_id, stream_version, state, state_codec_version, regfile_shape_hash, created_at, updated_at + FROM keiro.keiro_snapshots + WHERE stream_id = $1 + AND state_codec_version = $2 + AND regfile_shape_hash = $3 + ORDER BY stream_version DESC + LIMIT 1 + """ + ( contrazip3 + (E.param (E.nonNullable E.int8)) + (E.param (E.nonNullable E.int8)) + (E.param (E.nonNullable E.text)) + ) + (D.rowMaybe snapshotRowDecoder) + +writeSnapshotStmt :: Statement (Int64, Int64, Value, Int64, Text) () +writeSnapshotStmt = + preparable + """ + INSERT INTO keiro.keiro_snapshots + (stream_id, stream_version, state, state_codec_version, regfile_shape_hash) + VALUES + ($1, $2, $3, $4, $5) + ON CONFLICT (stream_id) DO UPDATE + SET stream_version = EXCLUDED.stream_version, + state = EXCLUDED.state, + state_codec_version = EXCLUDED.state_codec_version, + regfile_shape_hash = EXCLUDED.regfile_shape_hash, + updated_at = now() + WHERE keiro_snapshots.stream_version <= EXCLUDED.stream_version + OR keiro_snapshots.state_codec_version <> EXCLUDED.state_codec_version + OR keiro_snapshots.regfile_shape_hash <> EXCLUDED.regfile_shape_hash + """ + ( contrazip5 + (E.param (E.nonNullable E.int8)) + (E.param (E.nonNullable E.int8)) + (E.param (E.nonNullable E.jsonb)) + (E.param (E.nonNullable E.int8)) + (E.param (E.nonNullable E.text)) + ) + D.noResult + +snapshotRowDecoder :: D.Row SnapshotRow +snapshotRowDecoder = + SnapshotRow + <$> (StreamId <$> D.column (D.nonNullable D.int8)) + <*> (StreamVersion <$> D.column (D.nonNullable D.int8)) + <*> D.column (D.nonNullable D.jsonb) + <*> (Prelude.fromIntegral <$> D.column (D.nonNullable D.int8)) + <*> D.column (D.nonNullable D.text) + <*> D.column (D.nonNullable D.timestamptz) + <*> D.column (D.nonNullable D.timestamptz) + +streamIdToInt :: StreamId -> Int64 +streamIdToInt (StreamId value) = value + +streamVersionToInt :: StreamVersion -> Int64 +streamVersionToInt (StreamVersion value) = value + +snapshotWriteParams :: SnapshotWrite -> (Int64, Int64, Value, Int64, Text) +snapshotWriteParams snapshot = + ( streamIdToInt (snapshot ^. #streamId) + , streamVersionToInt (snapshot ^. #streamVersion) + , snapshot ^. #state + , Prelude.fromIntegral (snapshot ^. #stateCodecVersion) + , snapshot ^. #regfileShapeHash + ) diff --git a/src/Keiro/Subscription/Shard.hs b/src/Keiro/Subscription/Shard.hs new file mode 100644 --- /dev/null +++ b/src/Keiro/Subscription/Shard.hs @@ -0,0 +1,184 @@ +{- | Cooperative consumer-group ownership for category subscriptions (EP-51). + +kiroku already partitions a category into @N@ buckets (consumer-group members) by +a stable hash of the originating stream id, and keeps a per-member checkpoint, so +@N@ disjoint readers can drain a busy category in parallel. What kiroku leaves to +the operator is /membership/: "exactly one live process must own each member +index at a time" is, by itself, a manual @[0..N-1]@ wiring. This module supplies +the missing operability layer — a __lease__ over each bucket so a pool of +identical worker processes agree, with no external coordinator, on who owns which +bucket right now and re-divide the buckets automatically when a worker joins, +leaves, or dies. + +The storage and SQL live in "Keiro.Subscription.Shard.Schema"; this module is the +typed 'Eff'-level surface over kiroku's 'Store': + +* 'freshWorkerId' mints the per-process owner id. +* 'acquireOwnedBuckets' is the one-pass reconcile: renew the leases this worker + still holds, then claim up to a /fair share/ more (taking over any expired + leases), returning the buckets owned after the pass. +* 'renewOwnedBuckets' / 'relinquish' are the heartbeat and the graceful release. +* 'ensureShards' / 'ownershipSnapshot' populate and read the table. + +The lease, not a held lock, is the ownership mechanism: a transaction-scoped +advisory lock auto-releases at transaction end (so it cannot span a worker's +multi-transaction lifetime) and a session-scoped lock has no connection affinity +through kiroku's pooled 'Store' — the same finding +'Keiro.Workflow.Resume.WorkflowResumeOptions' records for the resume worker. A +renewable @lease_expires_at@ timestamp gives lifetime ownership and automatic +failover without depending on connection affinity, and disjointness rests on the +@FOR UPDATE SKIP LOCKED@ claim, not on the liveness estimate being exact. +-} +module Keiro.Subscription.Shard ( + -- * Worker identity + WorkerId (..), + freshWorkerId, + + -- * Lease descriptor + ShardLease (..), + ShardCountMismatch (..), + + -- * Ownership operations + ensureShards, + acquireOwnedBuckets, + renewOwnedBuckets, + relinquish, + ownershipSnapshot, + + -- * Fair-share helper + fairShareTarget, +) +where + +import Data.Set (Set) +import Data.Set qualified as Set +import Data.Time (NominalDiffTime) +import Data.UUID.V4 qualified as UUIDv4 +import Effectful (Eff, IOE, (:>)) +import Effectful.Exception (Exception, throwIO) +import Keiro.Prelude +import Keiro.Subscription.Shard.Schema ( + WorkerId (..), + claimShardsTx, + ensureShardRows, + listShardCounts, + listShardOwnership, + releaseShardsTx, + renewLeaseTx, + ) +import Kiroku.Store.Effect (Store) +import Kiroku.Store.Subscription.Types (SubscriptionName (..)) +import Kiroku.Store.Transaction (runTransaction) + +-- | Mint a fresh per-process 'WorkerId' (a random UUID). +freshWorkerId :: (IOE :> es) => Eff es WorkerId +freshWorkerId = WorkerId <$> liftIO UUIDv4.nextRandom + +{- | Everything an ownership pass needs for one @(subscription, worker)@: which +subscription is being sharded, this worker's id, the fixed bucket count @N@, and +how long a claim/renew is valid before it expires. +-} +data ShardLease = ShardLease + { subscriptionName :: !SubscriptionName + , workerId :: !WorkerId + , shardCount :: !Int + -- ^ @N@; the fixed number of buckets for this subscription name. + , leaseTtl :: !NominalDiffTime + -- ^ How long a claim or renewal keeps a bucket before it expires. + } + deriving stock (Generic) + +data ShardCountMismatch = ShardCountMismatch + { mismatchSubscriptionName :: !Text + , mismatchConfigured :: !Int + , mismatchFound :: ![Int] + } + deriving stock (Generic, Eq, Show) + deriving anyclass (Exception) + +{- | The fair-share claim target: @ceil(N / liveWorkers)@. When @k@ workers are +live they collectively claim all @N@ buckets and no single worker hogs them. A +non-positive @liveWorkers@ is treated as one (claim everything). +-} +fairShareTarget :: Int -> Int -> Int +fairShareTarget shardCount liveWorkers = + let k = max 1 liveWorkers + in (shardCount + k - 1) `div` k + +{- | Idempotently populate the @N@ shard rows for this subscription. Safe to call +on every worker startup ('ensureShardRows' uses @ON CONFLICT DO NOTHING@). +-} +ensureShards :: (Store :> es) => ShardLease -> Eff es () +ensureShards lease = do + counts <- runTransaction $ do + ensureShardRows (subscriptionName lease) (shardCount lease) + listShardCounts (subscriptionName lease) + let configured = shardCount lease + found = [n | (n, _) <- counts, n /= configured] + unless (null found) $ + throwIO + ShardCountMismatch + { mismatchSubscriptionName = case subscriptionName lease of + SubscriptionName name -> name + , mismatchConfigured = configured + , mismatchFound = found + } + +{- | One ownership-reconcile pass: in a single transaction, renew the leases this +worker still holds, then — if it holds fewer than its fair share — claim __one__ +more bucket (unowned or expired). Returns the set of buckets owned __after__ the +pass. + +Claiming __one at a time__ is deliberate and is what makes a pool of identical +workers converge to a fair split without any external coordinator. If a cold +worker grabbed its whole fair share at once it could, racing alone before its +peers' first pass, monopolise every bucket and then never see the idle peers +(they own nothing, so they are invisible in the lease table). Taking one bucket +per pass instead means concurrently-starting workers each grab one, become +visible after the first pass, and climb to an even share together; a worker +joining a balanced pool only picks up buckets freed by an expired lease +(failover). Ownership spreads over up to @N@ reconcile intervals — a deliberate +trade of spin-up latency for coordinator-free fairness. + +@liveWorkers@ is the caller's estimate of how many workers are currently live +(see 'ownershipSnapshot'); it tunes the fair-share target and self-corrects next +pass. It never causes double ownership, because the @FOR UPDATE SKIP LOCKED@ +claim is the real exclusion mechanism. +-} +acquireOwnedBuckets :: (IOE :> es, Store :> es) => ShardLease -> Int -> Eff es (Set Int) +acquireOwnedBuckets lease liveWorkers = do + now <- liftIO getCurrentTime + let target = fairShareTarget (shardCount lease) liveWorkers + runTransaction $ do + held <- renewLeaseTx (subscriptionName lease) (workerId lease) now (leaseTtl lease) + -- Claim at most one bucket per pass (see the note above on convergence). + claimed <- + if length held < target + then claimShardsTx (subscriptionName lease) (workerId lease) 1 now (leaseTtl lease) + else pure [] + pure (Set.fromList held <> Set.fromList claimed) + +{- | Renew only — write a fresh expiry for every bucket this worker still holds +and return them. Used when a worker wants to heartbeat without claiming more. +-} +renewOwnedBuckets :: (IOE :> es, Store :> es) => ShardLease -> Eff es (Set Int) +renewOwnedBuckets lease = do + now <- liftIO getCurrentTime + held <- runTransaction (renewLeaseTx (subscriptionName lease) (workerId lease) now (leaseTtl lease)) + pure (Set.fromList held) + +{- | Graceful release of the given buckets (clean shutdown), so they are +claimable immediately instead of after lease expiry. +-} +relinquish :: (Store :> es) => ShardLease -> Set Int -> Eff es () +relinquish lease buckets = + runTransaction (releaseShardsTx (subscriptionName lease) (workerId lease) (Set.toList buckets)) + +{- | Read every bucket's @(bucket, owner, lease_expires_at)@ for this +subscription. The worker uses it to estimate @liveWorkers@ (count of distinct +non-expired owners) before an 'acquireOwnedBuckets' pass. +-} +ownershipSnapshot :: + (Store :> es) => ShardLease -> Eff es [(Int, Maybe WorkerId, Maybe UTCTime)] +ownershipSnapshot lease = + runTransaction (listShardOwnership (subscriptionName lease)) diff --git a/src/Keiro/Subscription/Shard/Schema.hs b/src/Keiro/Subscription/Shard/Schema.hs new file mode 100644 --- /dev/null +++ b/src/Keiro/Subscription/Shard/Schema.hs @@ -0,0 +1,227 @@ +{- | The @keiro_subscription_shards@ table: storage and lease logic for +cooperative consumer-group ownership (EP-51). + +A category subscription can be split across @N@ buckets — kiroku consumer-group +member indices in @[0, N)@ — so that @N@ cooperating workers each drain a +disjoint slice of the keyspace. This module owns the durable __assignment__ +layer: one row per @(subscription_name, bucket)@ recording which worker holds it +right now, as a renewable __lease__ (an owner id plus an expiry timestamp). A +live worker renews its lease on a heartbeat; a dead worker stops renewing, its +lease expires, and another worker re-claims the bucket (failover). It does +__not__ store event positions — kiroku's per-member checkpoints +(@(subscription_name, consumer_group_member)@) do that, so a re-homed bucket +resumes where its previous owner left off. + +The statements here are 'Hasql.Transaction.Transaction'-flavoured so callers can +compose several into one short transaction (e.g. renew-then-claim in +'Keiro.Subscription.Shard.acquireOwnedBuckets'); the typed 'Eff'-level wrappers +that run them through kiroku's pool live in "Keiro.Subscription.Shard". The +claim uses @FOR UPDATE SKIP LOCKED@ over the claimable rows, exactly as +'Keiro.Timer.Schema.claimDueTimer' does, so two workers racing the same bucket +can never both win — a stale "how many workers are live" estimate only changes +how aggressively a worker claims, never whether ownership stays disjoint. +-} +module Keiro.Subscription.Shard.Schema ( + -- * Worker identity + WorkerId (..), + + -- * Lease statements (composable within a transaction) + ensureShardRows, + claimShardsTx, + renewLeaseTx, + releaseShardsTx, + listShardOwnership, + listShardCounts, +) +where + +import Contravariant.Extras (contrazip2, contrazip3, contrazip4, contrazip5) +import Data.Int (Int32) +import Data.Time (NominalDiffTime, addUTCTime) +import Data.UUID (UUID) +import Hasql.Decoders qualified as D +import Hasql.Encoders qualified as E +import Hasql.Statement (Statement, preparable) +import Keiro.Prelude +import Kiroku.Store.Subscription.Types (SubscriptionName (..)) +import "hasql-transaction" Hasql.Transaction qualified as Tx + +{- | A per-process unique id naming the owner in a lease row. A UUID minted once +at worker start ('Keiro.Subscription.Shard.freshWorkerId'); two restarts of the +same binary get two different ids, so a restarted process never inherits the +dead process's leases — it claims afresh once the old leases expire. +-} +newtype WorkerId = WorkerId UUID + deriving stock (Eq, Ord, Show) + +{- | Idempotently insert the @N@ rows @(name, bucket = 0..N-1, shard_count = N)@ +with @owner_worker_id@ left @NULL@. @ON CONFLICT DO NOTHING@ makes calling it +on every worker startup safe; it converges the table to exactly @N@ rows. +-} +ensureShardRows :: SubscriptionName -> Int -> Tx.Transaction () +ensureShardRows (SubscriptionName name) shardCount = + Tx.statement (name, fromIntegral shardCount) ensureShardRowsStmt + +{- | Claim up to @targetCount@ buckets that are currently unowned __or__ whose +lease has expired (@owner_worker_id IS NULL OR lease_expires_at < now@), in one +statement, returning the bucket numbers actually claimed. @FOR UPDATE SKIP +LOCKED@ over the claimable rows is the exclusion mechanism: two workers racing +the same bucket cannot both win. The TTL is added to @now@ here (in Haskell) to +form the new @lease_expires_at@. +-} +claimShardsTx :: + SubscriptionName -> WorkerId -> Int -> UTCTime -> NominalDiffTime -> Tx.Transaction [Int] +claimShardsTx (SubscriptionName name) (WorkerId worker) targetCount now ttl = + fmap (fmap fromIntegral) $ + Tx.statement + (name, now, addUTCTime ttl now, worker, fromIntegral targetCount) + claimShardsStmt + +{- | Renew every lease this worker still holds: write a fresh @lease_expires_at = +now + ttl@ and @heartbeat_at = now@ for each row it owns, returning the buckets +still held. A bucket stolen after this worker's lease lapsed is owned by someone +else and so is __not__ in the result — that is how a worker learns it lost a +bucket and stops reading it. +-} +renewLeaseTx :: SubscriptionName -> WorkerId -> UTCTime -> NominalDiffTime -> Tx.Transaction [Int] +renewLeaseTx (SubscriptionName name) (WorkerId worker) now ttl = + fmap (fmap fromIntegral) $ + Tx.statement (name, now, addUTCTime ttl now, worker) renewLeaseStmt + +{- | Graceful relinquish: clear ownership of the given buckets this worker holds +so they become claimable immediately, without waiting for lease expiry. Called +on clean shutdown. Only rows still owned by @worker@ are affected, so a bucket +already stolen is left untouched. +-} +releaseShardsTx :: SubscriptionName -> WorkerId -> [Int] -> Tx.Transaction () +releaseShardsTx (SubscriptionName name) (WorkerId worker) buckets = + Tx.statement (name, worker, fmap fromIntegral buckets) releaseShardsStmt + +{- | Observability/test read of @(bucket, owner, lease_expires_at)@ for one +subscription, ordered by bucket. +-} +listShardOwnership :: SubscriptionName -> Tx.Transaction [(Int, Maybe WorkerId, Maybe UTCTime)] +listShardOwnership (SubscriptionName name) = + Tx.statement name listShardOwnershipStmt + +-- | Read existing shard-count groups for a subscription as @(shard_count, rows)@. +listShardCounts :: SubscriptionName -> Tx.Transaction [(Int, Int)] +listShardCounts (SubscriptionName name) = + Tx.statement name listShardCountsStmt + +ensureShardRowsStmt :: Statement (Text, Int32) () +ensureShardRowsStmt = + preparable + """ + INSERT INTO keiro.keiro_subscription_shards (subscription_name, bucket, shard_count) + SELECT $1, g, $2 + FROM generate_series(0, $2 - 1) AS g + ON CONFLICT (subscription_name, bucket) DO NOTHING + """ + ( contrazip2 + (E.param (E.nonNullable E.text)) + (E.param (E.nonNullable E.int4)) + ) + D.noResult + +claimShardsStmt :: Statement (Text, UTCTime, UTCTime, UUID, Int32) [Int32] +claimShardsStmt = + preparable + """ + WITH claimable AS ( + SELECT bucket + FROM keiro.keiro_subscription_shards + WHERE subscription_name = $1 + AND (owner_worker_id IS NULL OR lease_expires_at < $2) + ORDER BY bucket + LIMIT $5 + FOR UPDATE SKIP LOCKED + ) + UPDATE keiro.keiro_subscription_shards s + SET owner_worker_id = $4, + lease_expires_at = $3, + heartbeat_at = $2, + updated_at = $2 + FROM claimable c + WHERE s.subscription_name = $1 AND s.bucket = c.bucket + RETURNING s.bucket + """ + ( contrazip5 + (E.param (E.nonNullable E.text)) + (E.param (E.nonNullable E.timestamptz)) + (E.param (E.nonNullable E.timestamptz)) + (E.param (E.nonNullable E.uuid)) + (E.param (E.nonNullable E.int4)) + ) + (D.rowList (D.column (D.nonNullable D.int4))) + +renewLeaseStmt :: Statement (Text, UTCTime, UTCTime, UUID) [Int32] +renewLeaseStmt = + preparable + """ + UPDATE keiro.keiro_subscription_shards + SET lease_expires_at = $3, + heartbeat_at = $2, + updated_at = $2 + WHERE subscription_name = $1 + AND owner_worker_id = $4 + RETURNING bucket + """ + ( contrazip4 + (E.param (E.nonNullable E.text)) + (E.param (E.nonNullable E.timestamptz)) + (E.param (E.nonNullable E.timestamptz)) + (E.param (E.nonNullable E.uuid)) + ) + (D.rowList (D.column (D.nonNullable D.int4))) + +releaseShardsStmt :: Statement (Text, UUID, [Int32]) () +releaseShardsStmt = + preparable + """ + UPDATE keiro.keiro_subscription_shards + SET owner_worker_id = NULL, + lease_expires_at = NULL, + updated_at = now() + WHERE subscription_name = $1 + AND owner_worker_id = $2 + AND bucket = ANY($3) + """ + ( contrazip3 + (E.param (E.nonNullable E.text)) + (E.param (E.nonNullable E.uuid)) + (E.param (E.nonNullable (E.foldableArray (E.nonNullable E.int4)))) + ) + D.noResult + +listShardOwnershipStmt :: Statement Text [(Int, Maybe WorkerId, Maybe UTCTime)] +listShardOwnershipStmt = + preparable + """ + SELECT bucket, owner_worker_id, lease_expires_at + FROM keiro.keiro_subscription_shards + WHERE subscription_name = $1 + ORDER BY bucket + """ + (E.param (E.nonNullable E.text)) + (D.rowList ownershipRowDecoder) + +listShardCountsStmt :: Statement Text [(Int, Int)] +listShardCountsStmt = + preparable + """ + SELECT shard_count, count(*)::int + FROM keiro.keiro_subscription_shards + WHERE subscription_name = $1 + GROUP BY shard_count + ORDER BY shard_count + """ + (E.param (E.nonNullable E.text)) + (D.rowList ((,) <$> (fromIntegral <$> D.column (D.nonNullable D.int4)) <*> (fromIntegral <$> D.column (D.nonNullable D.int4)))) + +ownershipRowDecoder :: D.Row (Int, Maybe WorkerId, Maybe UTCTime) +ownershipRowDecoder = + (,,) + <$> (fromIntegral <$> D.column (D.nonNullable D.int4)) + <*> (fmap WorkerId <$> D.column (D.nullable D.uuid)) + <*> D.column (D.nullable D.timestamptz) diff --git a/src/Keiro/Subscription/Shard/Worker.hs b/src/Keiro/Subscription/Shard/Worker.hs new file mode 100644 --- /dev/null +++ b/src/Keiro/Subscription/Shard/Worker.hs @@ -0,0 +1,428 @@ +{- | The sharded category-subscription worker: a rebalance loop that turns +leased bucket ownership ("Keiro.Subscription.Shard") into running kiroku +consumer-group readers (EP-51). + +Start the __same__ worker binary @N@ times — on @N@ hosts, in @N@ containers, in +an autoscaling group — each calling 'runShardedSubscriptionGroup' with the same +'SubscriptionName' and 'ShardedWorkerOptions', and the workers cooperatively +partition the category among themselves: every event is processed at least once +and none are skipped. A brief ownership overlap can deliver an event more than +once, so handlers must be idempotent. No external coordinator +(etcd/ZooKeeper/Consul) — coordination lives in the +@keiro_subscription_shards@ lease table. + +== One pass + +'reconcileShardsOnce' is the single testable unit (like +'Keiro.Workflow.Resume.resumeWorkflowsOnce'): + +1. Estimate how many workers are live from the lease table. +2. 'Keiro.Subscription.Shard.acquireOwnedBuckets' — renew the leases this worker + still holds and claim up to a fair share more (taking over expired leases). +3. __Shed__ any buckets held beyond the fair share when more than one worker is + live, so a worker that grabbed too many on a cold start (when it briefly + believed it was alone) gives the excess back and the pool converges to an + even split. A lone worker never sheds — it must own every bucket. +4. Reconcile readers: open a kiroku consumer-group reader for each newly-owned + bucket, stop the reader for each newly-lost bucket. A bucket that moves owners + resumes at its own kiroku per-member checkpoint. Each event is acknowledged + only after its handler returns, so a shed bucket's checkpoint never covers an + unprocessed event and no event is dropped. + +'runShardedSubscriptionGroup' is the loop driver: mint a 'WorkerId', ensure the +shard rows exist, then run 'reconcileShardsOnce' every @renewInterval@ forever. +On graceful shutdown (the loop thread is killed and can run cleanup) a @finally@ +stops every reader this worker holds and relinquishes its leases so another +worker can claim immediately. A real process crash still recovers by lease +expiry. + +== Why @IO@, not @Eff@ + +Like 'Keiro.Workflow.Resume.runWorkflowResumeWorkerPush', this worker manages +long-lived 'Control.Concurrent' reader threads and takes the 'KirokuStore' handle +directly (each lease pass runs through 'Kiroku.Store.Effect.runStoreIO'), so its +natural home is 'IO'. The compatibility handler is an ordinary +@'RecordedEvent' -> 'IO' ()@; 'runShardedSubscriptionGroupAck' exposes the +per-event 'ShardAck' surface for handlers that need an explicit retry or +dead-letter decision. A sharded subscription delivers at-least-once (a brief +overlap is possible while a bucket changes owners), so the handler must be +idempotent — keyed on @eventId@ — exactly as keiro's async-projection guidance +already requires. + +A synchronous exception from either handler is retried in place according to +'retryPolicy', using 'handlerRetryDelay'. Exhausting the bounded delivery budget +records the event in kiroku's @kiroku.dead_letters@ table and advances to the next +event. 'ShardReaderDied' therefore reports stream-level failures, not ordinary +handler exceptions. An asynchronous exception from shedding or shutdown writes +no acknowledgement, so the event is redelivered by the next owner. + +A zombie worker that misses renewals past @leaseTtl@ may continue reading briefly +after another worker claims its bucket, which can duplicate deliveries. It cannot +regress the consumer-group checkpoint: kiroku's checkpoint upsert is monotonic +(@GREATEST@), so a late acknowledgement from the laggard never moves progress +backward. +-} +module Keiro.Subscription.Shard.Worker ( + -- * Options + ShardWorkerError (..), + ShardedWorkerOptions (..), + ShardedWorkerConfigError (..), + defaultShardedWorkerOptions, + mkShardedWorkerOptions, + acquireOutcome, + + -- * Per-event acknowledgement + ShardAck (..), + ShardDelivery (..), + ShardEventHandler, + RetryDelay (..), + DeadLetterReason (..), + + -- * Running + reconcileShardsOnce, + runShardedSubscriptionGroup, + runShardedSubscriptionGroupAck, +) +where + +import Control.Concurrent (forkFinally, killThread, threadDelay) +import Control.Concurrent.STM (atomically, putTMVar) +import Control.Exception (SomeAsyncException, SomeException, catch, displayException, finally, fromException, throwIO) +import Control.Monad (forever) +import Data.Bifunctor (first) +import Data.IORef (IORef, atomicModifyIORef', newIORef, readIORef, writeIORef) +import Data.Int (Int32) +import Data.List (sort) +import Data.Map.Strict (Map) +import Data.Map.Strict qualified as Map +import Data.Set (Set) +import Data.Set qualified as Set +import Data.Text qualified as Text +import Data.Time (NominalDiffTime) +import Data.UUID.V4 qualified as UUIDv4 +import Keiro.Prelude +import Keiro.Subscription.Shard ( + ShardLease (..), + WorkerId (..), + acquireOwnedBuckets, + ensureShards, + fairShareTarget, + ownershipSnapshot, + relinquish, + ) +import Kiroku.Store.Connection (KirokuStore) +import Kiroku.Store.Effect (runStoreIO) +import Kiroku.Store.Subscription.Stream (AckItem (..), subscriptionAckStream) +import Kiroku.Store.Subscription.Types ( + ConsumerGroup (..), + DeadLetterReason (..), + RetryDelay (..), + RetryPolicy (..), + SubscriptionName, + SubscriptionResult (..), + SubscriptionTarget, + defaultRetryPolicy, + defaultSubscriptionConfig, + ) +import Kiroku.Store.Subscription.Types qualified as Sub +import Kiroku.Store.Types (RecordedEvent) +import Numeric.Natural (Natural) +import Streamly.Data.Fold qualified as Fold +import Streamly.Data.Stream qualified as Stream + +data ShardWorkerError + = ShardSnapshotFailed !Text + | ShardAcquireFailed !Text + | ShardReaderDied !Int !Text + | ShardEnsureFailed !Text + deriving stock (Generic, Eq, Show) + +-- | Per-event disposition returned by an acknowledgement-aware shard handler. +data ShardAck + = -- | Processing completed; the checkpoint may advance past this event. + ShardAckOk + | -- | Redeliver after the delay, bounded by 'retryPolicy'. + ShardAckRetry !RetryDelay + | -- | Record the event in kiroku's dead-letter table and advance immediately. + ShardAckDeadLetter !DeadLetterReason + deriving stock (Generic, Eq, Show) + +-- | One delivery to an acknowledgement-aware shard handler. +data ShardDelivery = ShardDelivery + { event :: !RecordedEvent + -- ^ The delivered event. + , attempt :: !Word + -- ^ Zero-based redelivery count: 0 initially, 1 after the first retry, and so on. + , bucket :: !Int + -- ^ The consumer-group member owned by this reader. + } + deriving stock (Generic, Eq, Show) + +type ShardEventHandler = ShardDelivery -> IO ShardAck + +-- | How a sharded worker pool runs one subscription. +data ShardedWorkerOptions = ShardedWorkerOptions + { shardCount :: !Int + -- ^ @N@ buckets, fixed per subscription name (every worker must agree on @N@). + , leaseTtl :: !NominalDiffTime + -- ^ How long a claim/renew keeps a bucket before it expires (default 30 s). + , renewInterval :: !NominalDiffTime + {- ^ Gap between reconcile passes; well under 'leaseTtl' so a live worker renews + several times per TTL (default 10 s ⇒ ~3 renews per 30 s TTL). A single + missed renewal does not lose ownership; a dead worker loses every bucket + within one TTL. + -} + , target :: !SubscriptionTarget + -- ^ The category (or @AllStreams@) to shard. + , batchSize :: !Int32 + -- ^ Events per database fetch per bucket reader (default 100). + , bufferSize :: !Natural + -- ^ Per-reader bridge queue capacity (default 256; one item is in flight). + , handlerRetryDelay :: !RetryDelay + -- ^ Delay before redelivering after a synchronous handler exception (default 1 s). + , retryPolicy :: !RetryPolicy + -- ^ Maximum total deliveries before retry exhaustion dead-letters the event. + , onShardError :: !(Maybe (ShardWorkerError -> IO ())) + -- ^ Optional error hook. Wire this to the application logger in production. + } + deriving stock (Generic) + +data ShardedWorkerConfigError + = InvalidShardCount !Int + | InvalidShardLeaseTtl !NominalDiffTime + | InvalidShardRenewInterval !NominalDiffTime + | InvalidShardLeaseRenewInterval !NominalDiffTime !NominalDiffTime + | InvalidShardBatchSize !Int32 + | InvalidShardBufferSize !Natural + | InvalidShardHandlerRetryDelay !RetryDelay + | InvalidShardRetryMaxAttempts !Int + deriving stock (Generic, Eq, Show) + +{- | Sensible defaults for a sharded worker: 30 s lease, 10 s renew, batch 100, +buffer 256. Supply the category target and the bucket count @N@. +-} +defaultShardedWorkerOptions :: SubscriptionTarget -> Int -> ShardedWorkerOptions +defaultShardedWorkerOptions target' shardCount' = + ShardedWorkerOptions + { shardCount = shardCount' + , leaseTtl = 30 + , renewInterval = 10 + , target = target' + , batchSize = 100 + , bufferSize = 256 + , handlerRetryDelay = RetryDelay 1 + , retryPolicy = defaultRetryPolicy + , onShardError = Nothing + } + +-- | Validate sharded worker options before starting a worker pool member. +mkShardedWorkerOptions :: ShardedWorkerOptions -> Either ShardedWorkerConfigError ShardedWorkerOptions +mkShardedWorkerOptions opts + | opts ^. #shardCount < 1 = Left (InvalidShardCount (opts ^. #shardCount)) + | opts ^. #leaseTtl <= 0 = Left (InvalidShardLeaseTtl (opts ^. #leaseTtl)) + | opts ^. #renewInterval <= 0 = Left (InvalidShardRenewInterval (opts ^. #renewInterval)) + | opts ^. #leaseTtl <= opts ^. #renewInterval = + Left (InvalidShardLeaseRenewInterval (opts ^. #leaseTtl) (opts ^. #renewInterval)) + | opts ^. #batchSize < 1 = Left (InvalidShardBatchSize (opts ^. #batchSize)) + | opts ^. #bufferSize < 1 = Left (InvalidShardBufferSize (opts ^. #bufferSize)) + | RetryDelay delay <- opts ^. #handlerRetryDelay + , delay < 0 = + Left (InvalidShardHandlerRetryDelay (opts ^. #handlerRetryDelay)) + | RetryPolicy attempts <- opts ^. #retryPolicy + , attempts < 1 = + Left (InvalidShardRetryMaxAttempts attempts) + | otherwise = Right opts + +{- | A live per-bucket reader: the action that stops it (cancels the kiroku +subscription and kills the drain thread). +-} +newtype RunningReader = RunningReader {stopReader :: IO ()} + +reportShardError :: ShardedWorkerOptions -> ShardWorkerError -> IO () +reportShardError opts err = + for_ (opts ^. #onShardError) ($ err) + +acquireOutcome :: Set Int -> Either Text (Set Int) -> (Set Int, Maybe ShardWorkerError) +acquireOutcome previous = \case + Right owned -> (owned, Nothing) + Left err -> (previous, Just (ShardAcquireFailed err)) + +{- | Run one ownership-reconcile pass and bring the set of running readers in +line with the buckets owned afterwards. Returns the buckets this worker owns +after the pass. The @readers@ ref maps each owned bucket to its live reader. + +This is the testable unit: a single call claims/renews/sheds leases and +starts/stops readers once, with no loop of its own. +-} +reconcileShardsOnce :: + KirokuStore -> + ShardLease -> + ShardedWorkerOptions -> + IORef (Map Int RunningReader) -> + ShardEventHandler -> + IO (Set Int) +reconcileShardsOnce store lease opts readers handler = do + now <- getCurrentTime + current <- readIORef readers + -- Estimate live workers: distinct owners with a non-expired lease, plus self. + snapResult <- runStoreIO store (ownershipSnapshot lease) + snap <- case snapResult of + Right rows -> pure rows + Left err -> do + reportShardError opts (ShardSnapshotFailed (Text.pack (show err))) + pure [] + let liveOwners = Set.fromList [w | (_, Just w, Just expiresAt) <- snap, expiresAt > now] + liveWorkers = Set.size (Set.insert (lease ^. #workerId) liveOwners) + shareTarget = fairShareTarget (lease ^. #shardCount) liveWorkers + -- Renew held + claim up to fair share. + claimedResult <- runStoreIO store (acquireOwnedBuckets lease liveWorkers) + let previousOwned = Map.keysSet current + (claimed, mAcquireError) = acquireOutcome previousOwned (first (Text.pack . show) claimedResult) + for_ mAcquireError (reportShardError opts) + -- Shed any excess above the fair share so a cold-start over-claim self-balances + -- (never when alone: a lone worker must own everything). + owned <- + if liveWorkers > 1 && Set.size claimed > shareTarget + then do + let excess = Set.fromList (drop shareTarget (sort (Set.toList claimed))) + _ <- runStoreIO store (relinquish lease excess) + pure (claimed `Set.difference` excess) + else pure claimed + -- Bring readers in line with `owned`: start newly-owned, stop newly-lost. + let running = Map.keysSet current + toStart = owned `Set.difference` running + toStop = running `Set.difference` owned + for_ (Set.toList toStop) $ \bucket -> + for_ (Map.lookup bucket current) stopReader + started <- + traverse + (\bucket -> (,) bucket <$> startReader store lease opts readers handler bucket) + (Set.toList toStart) + atomicModifyIORef' readers $ \m -> + let afterStop = foldr Map.delete m (Set.toList toStop) + afterStart = foldr (\(b, r) -> Map.insert b r) afterStop started + in (afterStart, ()) + pure owned + +{- | Open a kiroku consumer-group reader for one bucket and fork a thread that +drains it into the handler. The returned 'RunningReader' cancels the +subscription (which terminates the drain) and kills the thread. +-} +startReader :: + KirokuStore -> + ShardLease -> + ShardedWorkerOptions -> + IORef (Map Int RunningReader) -> + ShardEventHandler -> + Int -> + IO RunningReader +startReader store lease opts readers handler bucket = do + stopping <- newIORef False + let subConfig = + (defaultSubscriptionConfig (lease ^. #subscriptionName) (opts ^. #target) (\_ -> pure Continue)) + { Sub.batchSize = opts ^. #batchSize + , Sub.consumerGroup = + Just (ConsumerGroup{member = fromIntegral bucket, size = fromIntegral (opts ^. #shardCount)}) + , Sub.retryPolicy = opts ^. #retryPolicy + } + handleItem item = do + outcome <- + handler + ShardDelivery + { event = ackEvent item + , attempt = ackAttempt item + , bucket = bucket + } + `catch` handlerException + atomically (putTMVar (ackReply item) (toSubscriptionResult outcome)) + handlerException err = + case fromException err of + Just async -> throwIO (async :: SomeAsyncException) + Nothing -> pure (ShardAckRetry (opts ^. #handlerRetryDelay)) + (stream, cancelAction) <- subscriptionAckStream store subConfig (opts ^. #bufferSize) + tid <- + forkFinally (Stream.fold (Fold.drainMapM handleItem) stream) $ \result -> do + intentional <- readIORef stopping + unless intentional $ do + atomicModifyIORef' readers (\m -> (Map.delete bucket m, ())) + let reason = case result of + Left err -> Text.pack (displayException (err :: SomeException)) + Right _ -> "reader stream ended" + reportShardError opts (ShardReaderDied bucket reason) + pure + ( RunningReader $ do + writeIORef stopping True + cancelAction + killThread tid + ) + +toSubscriptionResult :: ShardAck -> SubscriptionResult +toSubscriptionResult = \case + ShardAckOk -> Continue + ShardAckRetry delay -> Retry delay + ShardAckDeadLetter reason -> DeadLetter reason + +{- | The loop driver: mint a 'WorkerId', ensure the @N@ shard rows exist, then +'reconcileShardsOnce' every @renewInterval@ forever. On shutdown (the loop thread +is killed) a @finally@ stops every reader this worker holds, so a crashed +worker's buckets stop being read immediately; its leases then expire and a +surviving worker re-claims them. + +The fixed @renewInterval@ between passes (the 'threadDelay' in 'loop') is the +__rebalance-signal seam__ (EP-51 Milestone 6). The shipped default is a pure poll: +correctness — disjointness and failover — rests entirely on the lease table and +does not depend on any notification. The EP-50 'Keiro.Wake' channel wakes on event +/appends/ (@kiroku.events@), which is a different event than a shard ownership +/change/; signalling a prompt rebalance on a worker join or a voluntary relinquish +would ride a dedicated @keiro_shard_rebalance@ @NOTIFY@ fired on claim/release, and +the swap is local to this one 'threadDelay' (replace it with a bounded wait on that +channel, exactly as 'Keiro.Workflow.Resume.runPollLoopWith' does for appends). Left +as the poll default here because it is a latency optimisation, not a correctness +requirement. +-} +runShardedSubscriptionGroup :: + KirokuStore -> + SubscriptionName -> + ShardedWorkerOptions -> + (RecordedEvent -> IO ()) -> + IO () +runShardedSubscriptionGroup store subName opts handler = + runShardedSubscriptionGroupAck store subName opts $ \delivery -> do + handler (delivery ^. #event) + pure ShardAckOk + +{- | Acknowledgement-aware loop driver. Unlike the compatibility wrapper, the +handler decides whether each event advances, retries, or dead-letters. +-} +runShardedSubscriptionGroupAck :: + KirokuStore -> + SubscriptionName -> + ShardedWorkerOptions -> + ShardEventHandler -> + IO () +runShardedSubscriptionGroupAck store subName opts handler = do + worker <- WorkerId <$> UUIDv4.nextRandom + let lease = + ShardLease + { subscriptionName = subName + , workerId = worker + , shardCount = opts ^. #shardCount + , leaseTtl = opts ^. #leaseTtl + } + ensured <- runStoreIO store (ensureShards lease) + case ensured of + Right () -> pure () + Left err -> reportShardError opts (ShardEnsureFailed (Text.pack (show err))) + readers <- newIORef Map.empty + loop lease readers `finally` cleanup lease readers + where + delayMicros = max 1 (round (realToFrac (opts ^. #renewInterval) * 1e6 :: Double)) + loop lease readers = + forever $ do + _ <- reconcileShardsOnce store lease opts readers handler + threadDelay delayMicros + cleanup lease readers = do + current <- readIORef readers + for_ (Map.elems current) stopReader + _ <- runStoreIO store (relinquish lease (Map.keysSet current)) + pure () diff --git a/src/Keiro/Telemetry.hs b/src/Keiro/Telemetry.hs new file mode 100644 --- /dev/null +++ b/src/Keiro/Telemetry.hs @@ -0,0 +1,902 @@ +{- | Thin OpenTelemetry surface for the keiro library. + +This module is the single place keiro reaches for @hs-opentelemetry-api@ +and @hs-opentelemetry-semantic-conventions@. Callers configure a 'Tracer' +on the application side (typically via @hs-opentelemetry-sdk@'s +'OpenTelemetry.Trace.makeTracer'), then pass it through to keiro's +publisher / consumer / command surfaces. + +When no tracer is supplied, every helper degrades to a thin pass-through +(it calls the body and returns its value), so applications that do not +yet wire OpenTelemetry are unaffected. + +# Attribute keys + +keiro links @hs-opentelemetry-semantic-conventions@ @1.40.0.0@ (generated +from spec @v1.40@) directly. Every messaging.* / db.* typed 'AttributeKey' +the keiro audit cites (@docs/research/opentelemetry-semconv-audit.md@) is +imported from @OpenTelemetry.SemanticConventions@ and re-exported from this +module, so 'Keiro.Telemetry' remains the one-stop telemetry surface for the +library while every convention name is anchored to the spec-generated module +rather than a hand-typed string. + +Only the @keiro.*@ keys ('keiro_stream_name', 'keiro_retry_attempt', +'keiro_events_appended', 'keiro_replay_divergence') are defined locally: they +are bespoke to keiro and have no upstream equivalent. +-} +module Keiro.Telemetry ( + -- * Span helpers + Tracer, + withProducerSpan, + withConsumerSpan, + withCommandSpan, + withWorkflowSpan, + + -- * W3C TraceContext bridge + traceContextFromCurrentSpan, + traceContextFromHeaders, + injectTraceContext, + + -- * Re-exported semantic-convention 'AttributeKey's + + -- + -- $semconv_keys + messaging_operation_type, + messaging_operation_name, + messaging_destination_partition_id, + messaging_consumer_group_name, + messaging_client_id, + messaging_kafka_offset, + db_system_name, + db_namespace, + db_collection_name, + db_operation_name, + + -- * Bespoke keiro 'AttributeKey's + keiro_stream_name, + keiro_retry_attempt, + keiro_events_appended, + keiro_replay_divergence, + keiro_workflow_name, + keiro_workflow_id, + keiro_workflow_step, + + -- * Metrics surface + + -- + -- $metrics + Meter, + InstrumentationLibrary (..), + keiroInstrumentationLibrary, + keiroOutboxBacklogName, + keiroOutboxPublishedName, + keiroOutboxRetriedName, + keiroOutboxDeadletteredName, + keiroOutboxReclaimedName, + keiroInboxProcessedName, + keiroInboxDuplicatesName, + keiroInboxFailedName, + keiroInboxPoisonedName, + keiroInboxBacklogName, + keiroTimerBacklogName, + keiroTimerFireLagName, + keiroTimerAttemptsName, + keiroTimerStuckName, + keiroTimerRequeuedName, + keiroProjectionLagName, + keiroProjectionWaitTimeoutsName, + keiroCommandConflictsName, + keiroCommandRetriesName, + keiroCommandDuplicatesName, + keiroSnapshotDecodeFailuresName, + keiroSnapshotEncodeFailuresName, + keiroSnapshotReadHitsName, + keiroSnapshotReadMissesName, + keiroSnapshotWriteFailuresName, + keiroSnapshotApplyDivergenceName, + keiroDispatchFailedName, + keiroDispatchDeadletteredName, + keiroSubscriptionDeadletteredName, + keiroDispatchDuplicatesName, + keiroDispatchPoisonName, + keiroWorkflowStepsExecutedName, + keiroWorkflowStepsReplayedName, + keiroWorkflowResumedName, + keiroWorkflowFailedName, + keiroWorkflowResumeErrorsName, + keiroWorkflowLeaseSkippedName, + keiroWorkflowJournalLengthName, + keiroWorkflowAwakeablesPendingName, + keiroWorkflowActiveName, + KeiroMetrics (..), + newKeiroMetrics, + recordOutboxBacklog, + recordOutboxPublished, + recordOutboxRetried, + recordOutboxDeadlettered, + recordOutboxReclaimed, + recordInboxProcessed, + recordInboxDuplicates, + recordInboxFailed, + recordInboxPoisoned, + recordInboxBacklog, + recordTimerBacklog, + recordTimerFireLag, + recordTimerAttempts, + recordTimerStuck, + recordTimerRequeued, + recordProjectionLag, + recordProjectionWaitTimeouts, + recordCommandConflicts, + recordCommandRetries, + recordCommandDuplicates, + recordSnapshotDecodeFailures, + recordSnapshotEncodeFailures, + recordSnapshotReadHits, + recordSnapshotReadMisses, + recordSnapshotWriteFailures, + recordSnapshotApplyDivergence, + recordDispatchFailed, + recordDispatchDeadLettered, + recordSubscriptionDeadLettered, + recordDispatchDuplicate, + recordDispatchPoison, + recordWorkflowStepExecuted, + recordWorkflowStepReplayed, + recordWorkflowResumed, + recordWorkflowFailed, + recordWorkflowResumeErrors, + recordWorkflowLeaseSkipped, + recordWorkflowActive, + recordWorkflowJournalLength, + recordWorkflowAwakeablesPending, + + -- * Kiroku observability bridge + kirokuEventBridge, +) +where + +import "base" Control.Exception (bracket) +import "base" GHC.Stack (HasCallStack) +import "bytestring" Data.ByteString qualified as ByteString +import "hs-opentelemetry-api" OpenTelemetry.Attributes (emptyAttributes) +import "hs-opentelemetry-api" OpenTelemetry.Attributes.Key (AttributeKey (..)) +import "hs-opentelemetry-api" OpenTelemetry.Context (insertSpan, lookupSpan) +import "hs-opentelemetry-api" OpenTelemetry.Context.ThreadLocal ( + attachContext, + detachContext, + getContext, + ) +import "hs-opentelemetry-api" OpenTelemetry.Metric.Core ( + Counter, + Gauge, + Histogram, + Meter, + counterAdd, + defaultAdvisoryParameters, + gaugeRecord, + histogramRecord, + meterCreateCounterInt64, + meterCreateGaugeInt64, + meterCreateHistogram, + ) +import "hs-opentelemetry-api" OpenTelemetry.Trace.Core ( + InstrumentationLibrary (..), + Span, + SpanArguments (..), + SpanKind (..), + Tracer, + addAttribute, + defaultSpanArguments, + inSpan', + wrapSpanContext, + ) +import "hs-opentelemetry-semantic-conventions" OpenTelemetry.SemanticConventions ( + db_collection_name, + db_namespace, + db_operation_name, + db_system_name, + messaging_client_id, + messaging_consumer_group_name, + messaging_destination_name, + messaging_destination_partition_id, + messaging_kafka_message_key, + messaging_kafka_offset, + messaging_message_id, + messaging_operation_name, + messaging_operation_type, + messaging_system, + ) +import "text" Data.Text qualified as Text +import "text" Data.Text.Encoding qualified as TE +import "unliftio-core" Control.Monad.IO.Unlift (MonadUnliftIO, withRunInIO) + +import Keiro.Inbox.Kafka (KafkaInboundRecord) +import Keiro.Integration.Event ( + IntegrationEvent, + TraceContext (..), + headerTraceParent, + headerTraceState, + ) +import Keiro.Outbox.Kafka (KafkaProducerRecord) +import Keiro.Prelude +import Keiro.Workflow.Types (StepName (..), WorkflowId (..), WorkflowName (..)) +import Kiroku.Store.Observability (KirokuEvent (..)) + +import "hs-opentelemetry-propagator-w3c" OpenTelemetry.Propagator.W3CTraceContext ( + decodeSpanContext, + encodeSpanContext, + ) + +-- --------------------------------------------------------------------------- +-- Bespoke keiro AttributeKeys +-- --------------------------------------------------------------------------- + +{- $semconv_keys +The messaging.* / db.* 'AttributeKey's re-exported here are imported +directly from 'OpenTelemetry.SemanticConventions' +(@hs-opentelemetry-semantic-conventions@ @1.40.0.0@). They are surfaced +from this module so 'Keiro.Telemetry' stays the single telemetry import +for the library; their definitions live upstream. + +The @keiro_*@ keys below are bespoke to keiro and have no upstream +equivalent, so they are defined locally. +-} + +keiro_stream_name :: AttributeKey Text +keiro_stream_name = AttributeKey "keiro.stream.name" + +keiro_retry_attempt :: AttributeKey Int64 +keiro_retry_attempt = AttributeKey "keiro.retry.attempt" + +keiro_events_appended :: AttributeKey Int64 +keiro_events_appended = AttributeKey "keiro.events.appended" + +keiro_replay_divergence :: AttributeKey Text +keiro_replay_divergence = AttributeKey "keiro.replay.divergence" + +keiro_workflow_name :: AttributeKey Text +keiro_workflow_name = AttributeKey "keiro.workflow.name" + +keiro_workflow_id :: AttributeKey Text +keiro_workflow_id = AttributeKey "keiro.workflow.id" + +keiro_workflow_step :: AttributeKey Text +keiro_workflow_step = AttributeKey "keiro.workflow.step" + +-- --------------------------------------------------------------------------- +-- Span helpers +-- --------------------------------------------------------------------------- + +{- | Run @body@ inside a @Producer@-kind span named @"send " <> destination@ +populated with the messaging attributes prescribed by +@docs/research/opentelemetry-semconv-audit.md@ for the outbox publish +site. + +When the supplied 'Tracer' is 'Nothing', the body runs unwrapped and the +helper is a no-op pass-through. This keeps the cost of the helper at +"one 'Maybe' branch" for applications that have not yet configured a +tracer. + +The body receives the producer 'Span' so it can record a publish failure +via 'recordPublishError'. +-} +withProducerSpan :: + (MonadUnliftIO m, HasCallStack) => + Maybe Tracer -> + IntegrationEvent -> + KafkaProducerRecord -> + (Maybe Span -> m a) -> + m a +withProducerSpan Nothing _ _ body = body Nothing +withProducerSpan (Just tracer) event record body = + inSpan' tracer name args $ \sp -> do + setProducerAttributes sp event record + body (Just sp) + where + name = "send " <> (event ^. #destination) + args = defaultSpanArguments{kind = Producer} + +{- | Run @body@ inside a @Consumer@-kind span named @"process " <> topic@. + +Like 'withProducerSpan', the helper is a pass-through under a 'Nothing' +tracer. The 'KafkaInboundRecord' is required so the helper can populate +@messaging.kafka.offset@ and @messaging.destination.partition.id@ +without the caller threading them separately. + +The optional 'Text' is a consumer group name, recorded as +@messaging.consumer.group.name@ when present. The 'IntegrationEvent' is +attached when present (decode succeeded), so @messaging.message.id@ +is set; otherwise the helper records only the headers known from the +broker record. +-} +withConsumerSpan :: + (MonadUnliftIO m, HasCallStack) => + Maybe Tracer -> + -- | consumer group name (optional) + Maybe Text -> + KafkaInboundRecord -> + -- | decoded envelope; 'Nothing' on a decode failure path + Maybe IntegrationEvent -> + (Maybe Span -> m a) -> + m a +withConsumerSpan Nothing _ _ _ body = body Nothing +withConsumerSpan (Just tracer) consumerGroup record mEvent body = + withRemoteParent (record ^. #headers) $ + inSpan' tracer name args $ \sp -> do + setConsumerAttributes sp consumerGroup record mEvent + body (Just sp) + where + name = "process " <> (record ^. #topic) + args = defaultSpanArguments{kind = Consumer} + +{- | Run @body@ with the OpenTelemetry context temporarily augmented by a +parent span extracted from the supplied header list via the W3C +TraceContext propagator. + +When no @traceparent@ header is present (or it cannot be parsed) the +body runs unwrapped, so the helper is safe to call unconditionally. + +This is the bridge that makes a 'Consumer'-kind span open in this +process a *child* of the 'Producer'-kind span that emitted the message +in the upstream process, joining the two traces by trace id. +-} +withRemoteParent :: + (MonadUnliftIO m) => [(Text, Text)] -> m a -> m a +withRemoteParent hs body = + case parentSpanContext hs of + Nothing -> body + Just spanCtx -> withRunInIO $ \runInIO -> do + ctx <- getContext + let newCtx = insertSpan (wrapSpanContext spanCtx) ctx + bracket + (attachContext newCtx) + detachContext + (const (runInIO body)) + where + parentSpanContext hsList = + let tp = fmap TE.encodeUtf8 (Prelude.lookup headerTraceParent hsList) + ts = fmap TE.encodeUtf8 (Prelude.lookup headerTraceState hsList) + in decodeSpanContext tp ts + +{- | Open an @Internal@ span around a command run, named after the resolved +stream identifier. Attributes capture the stream name and (when the +caller supplies it) the retry attempt number. The number of events +appended is attached after a successful append by the caller via +'addAttribute span keiro_events_appended n'. +-} +withCommandSpan :: + (MonadUnliftIO m, HasCallStack) => + Maybe Tracer -> + -- | resolved stream name + Text -> + -- | retry attempt (1-based); 'Nothing' to omit + Maybe Int64 -> + (Maybe Span -> m a) -> + m a +withCommandSpan Nothing _ _ body = body Nothing +withCommandSpan (Just tracer) streamName retryAttempt body = + inSpan' tracer streamName args $ \sp -> do + addAttribute sp (unkey keiro_stream_name) streamName + case retryAttempt of + Nothing -> pure () + Just n -> addAttribute sp (unkey keiro_retry_attempt) n + body (Just sp) + where + args = defaultSpanArguments{kind = Internal} + +{- | Open an @Internal@ span around a workflow run (or a single step/resume when +a 'StepName' is supplied), named @"workflow " <> name@. Attributes carry the +bespoke @keiro.workflow.name@, @keiro.workflow.id@, and — when present — +@keiro.workflow.step@ keys. Like 'withCommandSpan', a 'Nothing' tracer makes the +helper a pass-through, so it is safe to call unconditionally. +-} +withWorkflowSpan :: + (MonadUnliftIO m, HasCallStack) => + Maybe Tracer -> + WorkflowName -> + WorkflowId -> + Maybe StepName -> + (Maybe Span -> m a) -> + m a +withWorkflowSpan Nothing _ _ _ body = body Nothing +withWorkflowSpan (Just tracer) name wid mStep body = + inSpan' tracer spanName args $ \sp -> do + addAttribute sp (unkey keiro_workflow_name) (unWorkflowName name) + addAttribute sp (unkey keiro_workflow_id) (unWorkflowId wid) + case mStep of + Nothing -> pure () + Just s -> addAttribute sp (unkey keiro_workflow_step) (unStepName s) + body (Just sp) + where + spanName = "workflow " <> unWorkflowName name + args = defaultSpanArguments{kind = Internal} + +-- --------------------------------------------------------------------------- +-- W3C TraceContext bridge +-- --------------------------------------------------------------------------- + +{- | Read the current thread-local span context and format it as a +'TraceContext'. Returns 'Nothing' when no span is active on the current +thread. + +The application is expected to have already configured the W3C +propagator on its 'TracerProvider' (so the propagator is responsible for +on-the-wire framing); this helper is the keiro-side bridge between the +in-memory span and the keiro 'TraceContext' record stored on +'IntegrationEvent' envelopes and outbox rows. +-} +traceContextFromCurrentSpan :: (MonadIO m) => m (Maybe TraceContext) +traceContextFromCurrentSpan = do + ctx <- getContext + case lookupSpan ctx of + Nothing -> pure Nothing + Just sp -> do + (traceparentBytes, tracestateBytes) <- liftIO (encodeSpanContext sp) + let traceparent = TE.decodeUtf8 traceparentBytes + tracestate + | ByteString.null tracestateBytes = Nothing + | otherwise = Just (TE.decodeUtf8 tracestateBytes) + pure (Just (TraceContext traceparent tracestate)) + +{- | Lift a 'TraceContext' out of a flat @[(Text, Text)]@ header list. This +is the mirror image of 'integrationHeaders': it does not validate the +@traceparent@ format (the W3C propagator's parser does that at consume +time); it merely converts the on-the-wire pair of headers to the keiro +envelope record. +-} +traceContextFromHeaders :: [(Text, Text)] -> Maybe TraceContext +traceContextFromHeaders hs = case Prelude.lookup headerTraceParent hs of + Nothing -> Nothing + Just tp -> Just (TraceContext tp (Prelude.lookup headerTraceState hs)) + +{- | Append the W3C @traceparent@ / @tracestate@ headers for the current +thread-local span to the supplied header list. When no span is active +on the current thread, the input list is returned unchanged. + +Used by adapters that build a flat header list from their own envelope +(e.g. the outbox publisher) so the headers carry the active span +context even if the caller did not capture a 'TraceContext' onto the +event explicitly. +-} +injectTraceContext :: (MonadIO m) => [(Text, Text)] -> m [(Text, Text)] +injectTraceContext hs = do + mctx <- traceContextFromCurrentSpan + pure $ case mctx of + Nothing -> hs + Just tc -> + hs + ++ [(headerTraceParent, tc ^. #traceparent)] + ++ maybe [] (\ts -> [(headerTraceState, ts)]) (tc ^. #tracestate) + +-- --------------------------------------------------------------------------- +-- Internal helpers +-- --------------------------------------------------------------------------- + +setProducerAttributes :: + (MonadIO m) => Span -> IntegrationEvent -> KafkaProducerRecord -> m () +setProducerAttributes sp event _record = do + addAttribute sp (unkey messaging_system) ("kafka" :: Text) + addAttribute sp (unkey messaging_operation_type) ("publish" :: Text) + addAttribute sp (unkey messaging_operation_name) ("send" :: Text) + addAttribute sp (unkey messaging_destination_name) (event ^. #destination) + addAttribute sp (unkey messaging_message_id) (event ^. #messageId) + case event ^. #key of + Nothing -> pure () + Just k -> addAttribute sp (unkey messaging_kafka_message_key) k + +setConsumerAttributes :: + (MonadIO m) => + Span -> + Maybe Text -> + KafkaInboundRecord -> + Maybe IntegrationEvent -> + m () +setConsumerAttributes sp consumerGroup record mEvent = do + addAttribute sp (unkey messaging_system) ("kafka" :: Text) + addAttribute sp (unkey messaging_operation_type) ("process" :: Text) + addAttribute sp (unkey messaging_operation_name) ("process" :: Text) + addAttribute sp (unkey messaging_destination_name) (record ^. #topic) + addAttribute sp (unkey messaging_destination_partition_id) (showText (record ^. #partition)) + addAttribute sp (unkey messaging_kafka_offset) (record ^. #offset) + case record ^. #key of + Nothing -> pure () + Just k -> addAttribute sp (unkey messaging_kafka_message_key) k + case consumerGroup of + Nothing -> pure () + Just g -> addAttribute sp (unkey messaging_consumer_group_name) g + case mEvent of + Nothing -> pure () + Just event -> addAttribute sp (unkey messaging_message_id) (event ^. #messageId) + +showText :: (Show a) => a -> Text +showText = Text.pack . show + +-- --------------------------------------------------------------------------- +-- Metrics surface +-- --------------------------------------------------------------------------- + +{- $metrics +Alongside the span helpers above, 'Keiro.Telemetry' exposes the library's +metrics surface: a 'KeiroMetrics' record holding every instrument keiro +records (built once from a 'Meter' by 'newKeiroMetrics'), and one +@record*@ helper per instrument that takes a @'Maybe' 'KeiroMetrics'@ and +no-ops on 'Nothing'. This mirrors the @'Maybe' 'Tracer'@ opt-in the span +helpers use: an application that never configures a 'MeterProvider' pays +only one 'Maybe' branch per recording site. The per-instrument name, unit, +kind, and description are catalogued in +@docs/research/opentelemetry-semconv-audit.md@. +-} + +{- | The instrumentation scope keiro tags all its metric instruments with. +Mirrors the @"keiro"@ scope name the span helpers use on the application's +'Tracer'. +-} +keiroInstrumentationLibrary :: InstrumentationLibrary +keiroInstrumentationLibrary = + InstrumentationLibrary + { libraryName = "keiro" + , libraryVersion = "" + , librarySchemaUrl = "" + , libraryAttributes = emptyAttributes + } + +keiroOutboxBacklogName :: Text +keiroOutboxBacklogName = "keiro.outbox.backlog" +keiroOutboxPublishedName :: Text +keiroOutboxPublishedName = "keiro.outbox.published" +keiroOutboxRetriedName :: Text +keiroOutboxRetriedName = "keiro.outbox.retried" +keiroOutboxDeadletteredName :: Text +keiroOutboxDeadletteredName = "keiro.outbox.deadlettered" +keiroOutboxReclaimedName :: Text +keiroOutboxReclaimedName = "keiro.outbox.reclaimed" +keiroInboxProcessedName :: Text +keiroInboxProcessedName = "keiro.inbox.processed" +keiroInboxDuplicatesName :: Text +keiroInboxDuplicatesName = "keiro.inbox.duplicates" +keiroInboxFailedName :: Text +keiroInboxFailedName = "keiro.inbox.failed" +keiroInboxPoisonedName :: Text +keiroInboxPoisonedName = "keiro.inbox.poisoned" +keiroInboxBacklogName :: Text +keiroInboxBacklogName = "keiro.inbox.backlog" +keiroTimerBacklogName :: Text +keiroTimerBacklogName = "keiro.timer.backlog" +keiroTimerFireLagName :: Text +keiroTimerFireLagName = "keiro.timer.fire.lag" +keiroTimerAttemptsName :: Text +keiroTimerAttemptsName = "keiro.timer.attempts" +keiroTimerStuckName :: Text +keiroTimerStuckName = "keiro.timer.stuck" +keiroTimerRequeuedName :: Text +keiroTimerRequeuedName = "keiro.timer.requeued" +keiroProjectionLagName :: Text +keiroProjectionLagName = "keiro.projection.lag" +keiroProjectionWaitTimeoutsName :: Text +keiroProjectionWaitTimeoutsName = "keiro.projection.wait.timeouts" +keiroCommandConflictsName :: Text +keiroCommandConflictsName = "keiro.command.conflicts" +keiroCommandRetriesName :: Text +keiroCommandRetriesName = "keiro.command.retries" +keiroCommandDuplicatesName :: Text +keiroCommandDuplicatesName = "keiro.command.duplicates" +keiroSnapshotDecodeFailuresName :: Text +keiroSnapshotDecodeFailuresName = "keiro.snapshot.decode.failures" +keiroSnapshotEncodeFailuresName :: Text +keiroSnapshotEncodeFailuresName = "keiro.snapshot.encode.failures" +keiroSnapshotReadHitsName :: Text +keiroSnapshotReadHitsName = "keiro.snapshot.read.hits" +keiroSnapshotReadMissesName :: Text +keiroSnapshotReadMissesName = "keiro.snapshot.read.misses" +keiroSnapshotWriteFailuresName :: Text +keiroSnapshotWriteFailuresName = "keiro.snapshot.write.failures" +keiroSnapshotApplyDivergenceName :: Text +keiroSnapshotApplyDivergenceName = "keiro.snapshot.apply.divergence" +keiroDispatchFailedName :: Text +keiroDispatchFailedName = "keiro.dispatch.failed" +keiroDispatchDeadletteredName :: Text +keiroDispatchDeadletteredName = "keiro.dispatch.deadlettered" +keiroSubscriptionDeadletteredName :: Text +keiroSubscriptionDeadletteredName = "keiro.subscription.deadlettered" +keiroDispatchDuplicatesName :: Text +keiroDispatchDuplicatesName = "keiro.dispatch.duplicates" +keiroDispatchPoisonName :: Text +keiroDispatchPoisonName = "keiro.dispatch.poison" +keiroWorkflowStepsExecutedName :: Text +keiroWorkflowStepsExecutedName = "keiro.workflow.steps.executed" +keiroWorkflowStepsReplayedName :: Text +keiroWorkflowStepsReplayedName = "keiro.workflow.steps.replayed" +keiroWorkflowResumedName :: Text +keiroWorkflowResumedName = "keiro.workflow.resumed" +keiroWorkflowFailedName :: Text +keiroWorkflowFailedName = "keiro.workflow.failed" +keiroWorkflowResumeErrorsName :: Text +keiroWorkflowResumeErrorsName = "keiro.workflow.resume.errors" +keiroWorkflowLeaseSkippedName :: Text +keiroWorkflowLeaseSkippedName = "keiro.workflow.lease.skipped" +keiroWorkflowJournalLengthName :: Text +keiroWorkflowJournalLengthName = "keiro.workflow.journal.length" +keiroWorkflowAwakeablesPendingName :: Text +keiroWorkflowAwakeablesPendingName = "keiro.workflow.awakeables.pending" +keiroWorkflowActiveName :: Text +keiroWorkflowActiveName = "keiro.workflow.active" + +{- | All metric instruments the keiro library records, built once from a +'Meter' by 'newKeiroMetrics'. Workers accept a @'Maybe' 'KeiroMetrics'@ and +treat 'Nothing' as "record nothing"; the per-instrument recording helpers in +this module take @'Maybe' 'KeiroMetrics'@ so call sites stay one-liners. + +Instrument kinds follow the keiro metrics policy: backlog and lag are +synchronous gauges recorded by each worker per poll pass; tallies are +monotonic counters; distributions are histograms. See +@docs/research/opentelemetry-semconv-audit.md@ for the per-instrument +name / unit / kind / description catalogue. +-} +data KeiroMetrics = KeiroMetrics + { outboxBacklog :: Gauge Int64 + , outboxPublished :: Counter Int64 + , outboxRetried :: Counter Int64 + , outboxDeadlettered :: Counter Int64 + , outboxReclaimed :: Counter Int64 + , inboxProcessed :: Counter Int64 + , inboxDuplicates :: Counter Int64 + , inboxFailed :: Counter Int64 + , inboxPoisoned :: Counter Int64 + , inboxBacklog :: Gauge Int64 + , timerBacklog :: Gauge Int64 + , timerFireLag :: Histogram + , timerAttempts :: Histogram + , timerStuck :: Gauge Int64 + , timerRequeued :: Counter Int64 + , projectionLag :: Gauge Int64 + , projectionWaitTimeouts :: Counter Int64 + , commandConflicts :: Counter Int64 + , commandRetries :: Counter Int64 + , commandDuplicates :: Counter Int64 + , snapshotDecodeFailures :: Counter Int64 + , snapshotEncodeFailures :: Counter Int64 + , snapshotReadHits :: Counter Int64 + , snapshotReadMisses :: Counter Int64 + , snapshotWriteFailures :: Counter Int64 + , snapshotApplyDivergence :: Counter Int64 + , dispatchFailed :: Counter Int64 + , dispatchDeadlettered :: Counter Int64 + , subscriptionDeadlettered :: Counter Int64 + , dispatchDuplicates :: Counter Int64 + , dispatchPoison :: Counter Int64 + , workflowStepsExecuted :: Counter Int64 + , workflowStepsReplayed :: Counter Int64 + , workflowResumed :: Counter Int64 + , workflowFailed :: Counter Int64 + , workflowResumeErrors :: Counter Int64 + , workflowLeaseSkipped :: Counter Int64 + , workflowActive :: Gauge Int64 + , workflowJournalLength :: Histogram + , workflowAwakeablesPending :: Gauge Int64 + } + +{- | Construct every keiro metric instrument from a 'Meter'. Call this once at +application start after building an SDK 'OpenTelemetry.Metric.Core.MeterProvider' +and obtaining a 'Meter' (e.g. @getMeter mp keiroInstrumentationLibrary@), then +thread the resulting 'KeiroMetrics' into workers as @'Just' metrics@. Under a +no-op meter every instrument is itself a no-op, so this is safe to call +unconditionally. +-} +newKeiroMetrics :: (MonadIO m) => Meter -> m KeiroMetrics +newKeiroMetrics meter = liftIO $ do + outboxBacklog' <- gaugeI64 keiroOutboxBacklogName "{event}" "Outbox rows awaiting publish." + outboxPublished' <- counterI64 keiroOutboxPublishedName "{event}" "Outbox events successfully published." + outboxRetried' <- counterI64 keiroOutboxRetriedName "{event}" "Outbox publish attempts that failed and will retry." + outboxDeadlettered' <- counterI64 keiroOutboxDeadletteredName "{event}" "Outbox events parked after exhausting retries." + outboxReclaimed' <- counterI64 keiroOutboxReclaimedName "{event}" "Outbox rows reclaimed from a crashed or stalled publisher." + inboxProcessed' <- counterI64 keiroInboxProcessedName "{message}" "Inbox messages processed successfully." + inboxDuplicates' <- counterI64 keiroInboxDuplicatesName "{message}" "Inbox messages skipped as duplicates." + inboxFailed' <- counterI64 keiroInboxFailedName "{message}" "Inbox messages whose handler failed." + inboxPoisoned' <- counterI64 keiroInboxPoisonedName "{message}" "Inbox messages dead-lettered after exhausting handler attempts." + inboxBacklog' <- gaugeI64 keiroInboxBacklogName "{message}" "Inbox messages awaiting processing." + timerBacklog' <- gaugeI64 keiroTimerBacklogName "{timer}" "Due timers awaiting firing." + timerFireLag' <- histogram keiroTimerFireLagName "ms" "Delay between a timer's scheduled time and when it fired." + timerAttempts' <- histogram keiroTimerAttemptsName "{attempt}" "Number of attempts a timer took to fire." + timerStuck' <- gaugeI64 keiroTimerStuckName "{timer}" "Timers stuck in the Firing state past threshold." + timerRequeued' <- counterI64 keiroTimerRequeuedName "{timer}" "Timers moved from firing back to scheduled after a stale claim." + projectionLag' <- gaugeI64 keiroProjectionLagName "{event}" "Events between the log head and a projection's checkpoint." + projectionWaitTimeouts' <- counterI64 keiroProjectionWaitTimeoutsName "{timeout}" "Position-wait calls that timed out before the projection caught up." + commandConflicts' <- counterI64 keiroCommandConflictsName "{conflict}" "Optimistic-concurrency conflicts observed by command runners." + commandRetries' <- counterI64 keiroCommandRetriesName "{retry}" "Command retry attempts started after an optimistic-concurrency conflict." + commandDuplicates' <- counterI64 keiroCommandDuplicatesName "{event}" "Command appends rejected as duplicate deterministic event ids." + snapshotDecodeFailures' <- counterI64 keiroSnapshotDecodeFailuresName "{failure}" "Snapshot rows whose bytes failed to decode; hydration fell back to full replay." + snapshotEncodeFailures' <- counterI64 keiroSnapshotEncodeFailuresName "{failure}" "Post-commit snapshot encodes that failed and were swallowed." + snapshotReadHits' <- counterI64 keiroSnapshotReadHitsName "{read}" "Snapshot lookups that yielded a usable hydration seed." + snapshotReadMisses' <- counterI64 keiroSnapshotReadMissesName "{read}" "Snapshot lookups that fell back to full replay." + snapshotWriteFailures' <- counterI64 keiroSnapshotWriteFailuresName "{failure}" "Post-commit snapshot writes that failed and were swallowed." + snapshotApplyDivergence' <- counterI64 keiroSnapshotApplyDivergenceName "{failure}" "Just-appended event batches that failed to replay from the pre-command state; the stream is poisoned and its next hydration will fail." + dispatchFailed' <- counterI64 keiroDispatchFailedName "{command}" "Process-manager/router dispatch commands that failed." + dispatchDeadlettered' <- counterI64 keiroDispatchDeadletteredName "{command}" "Rejected process-manager/router dispatch commands handled by dead-letter or skip policy." + subscriptionDeadlettered' <- counterI64 keiroSubscriptionDeadletteredName "{event}" "Kiroku source events dead-lettered by an explicit disposition or retry exhaustion." + dispatchDuplicates' <- counterI64 keiroDispatchDuplicatesName "{command}" "Process-manager/router dispatch commands skipped as duplicate deterministic event ids." + dispatchPoison' <- counterI64 keiroDispatchPoisonName "{message}" "Process-manager/router worker messages classified as poison." + workflowStepsExecuted' <- counterI64 keiroWorkflowStepsExecutedName "{step}" "Workflow steps that ran their action (a journal miss)." + workflowStepsReplayed' <- counterI64 keiroWorkflowStepsReplayedName "{step}" "Workflow steps short-circuited to a recorded result (a journal hit)." + workflowResumed' <- counterI64 keiroWorkflowResumedName "{workflow}" "Workflow re-invocations performed by the resume worker." + workflowFailed' <- counterI64 keiroWorkflowFailedName "{workflow}" "Workflow instances marked terminally failed by the resume worker." + workflowResumeErrors' <- counterI64 keiroWorkflowResumeErrorsName "{error}" "Transient store errors observed by the workflow resume worker." + workflowLeaseSkipped' <- counterI64 keiroWorkflowLeaseSkippedName "{workflow}" "Workflow instances skipped because another worker owns their lease." + workflowActive' <- gaugeI64 keiroWorkflowActiveName "{workflow}" "Workflow runs currently in progress in this process." + workflowJournalLength' <- histogram keiroWorkflowJournalLengthName "{event}" "Journal event count of a workflow at completion." + workflowAwakeablesPending' <- gaugeI64 keiroWorkflowAwakeablesPendingName "{awakeable}" "Awakeables awaiting an external signal." + pure + KeiroMetrics + { outboxBacklog = outboxBacklog' + , outboxPublished = outboxPublished' + , outboxRetried = outboxRetried' + , outboxDeadlettered = outboxDeadlettered' + , outboxReclaimed = outboxReclaimed' + , inboxProcessed = inboxProcessed' + , inboxDuplicates = inboxDuplicates' + , inboxFailed = inboxFailed' + , inboxPoisoned = inboxPoisoned' + , inboxBacklog = inboxBacklog' + , timerBacklog = timerBacklog' + , timerFireLag = timerFireLag' + , timerAttempts = timerAttempts' + , timerStuck = timerStuck' + , timerRequeued = timerRequeued' + , projectionLag = projectionLag' + , projectionWaitTimeouts = projectionWaitTimeouts' + , commandConflicts = commandConflicts' + , commandRetries = commandRetries' + , commandDuplicates = commandDuplicates' + , snapshotDecodeFailures = snapshotDecodeFailures' + , snapshotEncodeFailures = snapshotEncodeFailures' + , snapshotReadHits = snapshotReadHits' + , snapshotReadMisses = snapshotReadMisses' + , snapshotWriteFailures = snapshotWriteFailures' + , snapshotApplyDivergence = snapshotApplyDivergence' + , dispatchFailed = dispatchFailed' + , dispatchDeadlettered = dispatchDeadlettered' + , subscriptionDeadlettered = subscriptionDeadlettered' + , dispatchDuplicates = dispatchDuplicates' + , dispatchPoison = dispatchPoison' + , workflowStepsExecuted = workflowStepsExecuted' + , workflowStepsReplayed = workflowStepsReplayed' + , workflowResumed = workflowResumed' + , workflowFailed = workflowFailed' + , workflowResumeErrors = workflowResumeErrors' + , workflowLeaseSkipped = workflowLeaseSkipped' + , workflowActive = workflowActive' + , workflowJournalLength = workflowJournalLength' + , workflowAwakeablesPending = workflowAwakeablesPending' + } + where + counterI64 :: Text -> Text -> Text -> IO (Counter Int64) + counterI64 name unit desc = + meterCreateCounterInt64 meter name (Just unit) (Just desc) defaultAdvisoryParameters + gaugeI64 :: Text -> Text -> Text -> IO (Gauge Int64) + gaugeI64 name unit desc = + meterCreateGaugeInt64 meter name (Just unit) (Just desc) defaultAdvisoryParameters + histogram :: Text -> Text -> Text -> IO Histogram + histogram name unit desc = + meterCreateHistogram meter name (Just unit) (Just desc) defaultAdvisoryParameters + +-- Internal: record an Int64 on the counter selected by @sel@, or do nothing. +recordCounter :: + (MonadIO m) => (KeiroMetrics -> Counter Int64) -> Maybe KeiroMetrics -> Int64 -> m () +recordCounter _ Nothing _ = pure () +recordCounter sel (Just ms) n = liftIO (counterAdd (sel ms) n emptyAttributes) + +-- Internal: record an Int64 on the gauge selected by @sel@, or do nothing. +recordGaugeI64 :: + (MonadIO m) => (KeiroMetrics -> Gauge Int64) -> Maybe KeiroMetrics -> Int64 -> m () +recordGaugeI64 _ Nothing _ = pure () +recordGaugeI64 sel (Just ms) n = liftIO (gaugeRecord (sel ms) n emptyAttributes) + +-- Internal: record a Double on the histogram selected by @sel@, or do nothing. +recordHistogram :: + (MonadIO m) => (KeiroMetrics -> Histogram) -> Maybe KeiroMetrics -> Double -> m () +recordHistogram _ Nothing _ = pure () +recordHistogram sel (Just ms) v = liftIO (histogramRecord (sel ms) v emptyAttributes) + +recordOutboxBacklog :: (MonadIO m) => Maybe KeiroMetrics -> Int64 -> m () +recordOutboxBacklog = recordGaugeI64 outboxBacklog +recordOutboxPublished :: (MonadIO m) => Maybe KeiroMetrics -> Int64 -> m () +recordOutboxPublished = recordCounter outboxPublished +recordOutboxRetried :: (MonadIO m) => Maybe KeiroMetrics -> Int64 -> m () +recordOutboxRetried = recordCounter outboxRetried +recordOutboxDeadlettered :: (MonadIO m) => Maybe KeiroMetrics -> Int64 -> m () +recordOutboxDeadlettered = recordCounter outboxDeadlettered +recordOutboxReclaimed :: (MonadIO m) => Maybe KeiroMetrics -> Int64 -> m () +recordOutboxReclaimed = recordCounter outboxReclaimed +recordInboxProcessed :: (MonadIO m) => Maybe KeiroMetrics -> Int64 -> m () +recordInboxProcessed = recordCounter inboxProcessed +recordInboxDuplicates :: (MonadIO m) => Maybe KeiroMetrics -> Int64 -> m () +recordInboxDuplicates = recordCounter inboxDuplicates +recordInboxFailed :: (MonadIO m) => Maybe KeiroMetrics -> Int64 -> m () +recordInboxFailed = recordCounter inboxFailed +recordInboxPoisoned :: (MonadIO m) => Maybe KeiroMetrics -> Int64 -> m () +recordInboxPoisoned = recordCounter inboxPoisoned +recordInboxBacklog :: (MonadIO m) => Maybe KeiroMetrics -> Int64 -> m () +recordInboxBacklog = recordGaugeI64 inboxBacklog +recordTimerBacklog :: (MonadIO m) => Maybe KeiroMetrics -> Int64 -> m () +recordTimerBacklog = recordGaugeI64 timerBacklog +recordTimerFireLag :: (MonadIO m) => Maybe KeiroMetrics -> Double -> m () +recordTimerFireLag = recordHistogram timerFireLag +recordTimerAttempts :: (MonadIO m) => Maybe KeiroMetrics -> Double -> m () +recordTimerAttempts = recordHistogram timerAttempts +recordTimerStuck :: (MonadIO m) => Maybe KeiroMetrics -> Int64 -> m () +recordTimerStuck = recordGaugeI64 timerStuck +recordTimerRequeued :: (MonadIO m) => Maybe KeiroMetrics -> Int64 -> m () +recordTimerRequeued = recordCounter timerRequeued +recordProjectionLag :: (MonadIO m) => Maybe KeiroMetrics -> Int64 -> m () +recordProjectionLag = recordGaugeI64 projectionLag +recordProjectionWaitTimeouts :: (MonadIO m) => Maybe KeiroMetrics -> Int64 -> m () +recordProjectionWaitTimeouts = recordCounter projectionWaitTimeouts +recordCommandConflicts :: (MonadIO m) => Maybe KeiroMetrics -> Int64 -> m () +recordCommandConflicts = recordCounter commandConflicts +recordCommandRetries :: (MonadIO m) => Maybe KeiroMetrics -> Int64 -> m () +recordCommandRetries = recordCounter commandRetries +recordCommandDuplicates :: (MonadIO m) => Maybe KeiroMetrics -> Int64 -> m () +recordCommandDuplicates = recordCounter commandDuplicates +recordSnapshotDecodeFailures :: (MonadIO m) => Maybe KeiroMetrics -> Int64 -> m () +recordSnapshotDecodeFailures = recordCounter snapshotDecodeFailures +recordSnapshotEncodeFailures :: (MonadIO m) => Maybe KeiroMetrics -> Int64 -> m () +recordSnapshotEncodeFailures = recordCounter snapshotEncodeFailures +recordSnapshotReadHits :: (MonadIO m) => Maybe KeiroMetrics -> Int64 -> m () +recordSnapshotReadHits = recordCounter snapshotReadHits +recordSnapshotReadMisses :: (MonadIO m) => Maybe KeiroMetrics -> Int64 -> m () +recordSnapshotReadMisses = recordCounter snapshotReadMisses +recordSnapshotWriteFailures :: (MonadIO m) => Maybe KeiroMetrics -> Int64 -> m () +recordSnapshotWriteFailures = recordCounter snapshotWriteFailures +recordSnapshotApplyDivergence :: (MonadIO m) => Maybe KeiroMetrics -> Int64 -> m () +recordSnapshotApplyDivergence = recordCounter snapshotApplyDivergence +recordDispatchFailed :: (MonadIO m) => Maybe KeiroMetrics -> Int64 -> m () +recordDispatchFailed = recordCounter dispatchFailed +recordDispatchDeadLettered :: (MonadIO m) => Maybe KeiroMetrics -> Int64 -> m () +recordDispatchDeadLettered = recordCounter dispatchDeadlettered +recordSubscriptionDeadLettered :: (MonadIO m) => Maybe KeiroMetrics -> Int64 -> m () +recordSubscriptionDeadLettered = recordCounter subscriptionDeadlettered +recordDispatchDuplicate :: (MonadIO m) => Maybe KeiroMetrics -> Int64 -> m () +recordDispatchDuplicate = recordCounter dispatchDuplicates +recordDispatchPoison :: (MonadIO m) => Maybe KeiroMetrics -> Int64 -> m () +recordDispatchPoison = recordCounter dispatchPoison +recordWorkflowStepExecuted :: (MonadIO m) => Maybe KeiroMetrics -> Int64 -> m () +recordWorkflowStepExecuted = recordCounter workflowStepsExecuted +recordWorkflowStepReplayed :: (MonadIO m) => Maybe KeiroMetrics -> Int64 -> m () +recordWorkflowStepReplayed = recordCounter workflowStepsReplayed +recordWorkflowResumed :: (MonadIO m) => Maybe KeiroMetrics -> Int64 -> m () +recordWorkflowResumed = recordCounter workflowResumed +recordWorkflowFailed :: (MonadIO m) => Maybe KeiroMetrics -> Int64 -> m () +recordWorkflowFailed = recordCounter workflowFailed +recordWorkflowResumeErrors :: (MonadIO m) => Maybe KeiroMetrics -> Int64 -> m () +recordWorkflowResumeErrors = recordCounter workflowResumeErrors +recordWorkflowLeaseSkipped :: (MonadIO m) => Maybe KeiroMetrics -> Int64 -> m () +recordWorkflowLeaseSkipped = recordCounter workflowLeaseSkipped +recordWorkflowActive :: (MonadIO m) => Maybe KeiroMetrics -> Int64 -> m () +recordWorkflowActive = recordGaugeI64 workflowActive +recordWorkflowJournalLength :: (MonadIO m) => Maybe KeiroMetrics -> Double -> m () +recordWorkflowJournalLength = recordHistogram workflowJournalLength +recordWorkflowAwakeablesPending :: (MonadIO m) => Maybe KeiroMetrics -> Int64 -> m () +recordWorkflowAwakeablesPending = recordGaugeI64 workflowAwakeablesPending + +{- | Feed Kiroku store events into Keiro metrics, then delegate every event to +the application's existing event handler. Install this as (or inside) the +@eventHandler@ on Kiroku's @ConnectionSettings@ at store construction; pass +@const (pure ())@ when there is no other handler. + +'KirokuEventSubscriptionDeadLettered' is the terminal retry-exhaustion signal: +the acknowledgement bridge exposes the current delivery attempt, but does not +tell a handler that its retry reply consumed the final attempt. For current +dead-letter depth, query Kiroku's durable table rather than treating this +monotonic counter as a gauge: + +> SELECT count(*) FROM kiroku.dead_letters WHERE subscription_name = $1 + +The delegate runs synchronously, matching Kiroku's event-handler contract, so +it should remain fast and non-blocking. +-} +kirokuEventBridge :: Maybe KeiroMetrics -> (KirokuEvent -> IO ()) -> KirokuEvent -> IO () +kirokuEventBridge metrics delegate event = do + case event of + KirokuEventSubscriptionDeadLettered{} -> recordSubscriptionDeadLettered metrics 1 + _ -> pure () + delegate event diff --git a/src/Keiro/Timer.hs b/src/Keiro/Timer.hs new file mode 100644 --- /dev/null +++ b/src/Keiro/Timer.hs @@ -0,0 +1,179 @@ +{- | Durable timers for process managers. + +A process manager schedules a timer ('scheduleTimerTx', in its own append +transaction) to be woken at a future time — a saga timeout, a retry delay, a +deadline. The 'runTimerWorker' loop claims one due timer at a time with +@FOR UPDATE SKIP LOCKED@ (so multiple workers can run safely), hands it to a +caller-supplied @fire@ action that typically dispatches a command back into +the manager, and marks it fired once the resulting event id is known. A +timer left @Firing@ by a crash becomes claimable again after the worker's +configured stale-claim timeout, giving at-least-once firing. + +The wire types live in "Keiro.Timer.Types" and the SQL storage in +"Keiro.Timer.Schema"; both are re-exported here so most callers need only +import @Keiro.Timer@. +-} +module Keiro.Timer ( + -- * Timer types + TimerId (..), + TimerRequest (..), + TimerRow (..), + TimerStatus (..), + + -- * Storage + scheduleTimerTx, + scheduleTimerOnceTx, + claimDueTimer, + markTimerFired, + countDueTimers, + countStuckTimers, + + -- * Recovery + StuckTimerFilter (..), + anyStuckTimer, + findStuckTimers, + requeueStuckTimers, + requeueStuckTimer, + cancelTimer, + deadLetterTimer, + + -- * Worker + TimerWorkerOptions (..), + TimerWorkerConfigError (..), + defaultTimerWorkerOptions, + mkTimerWorkerOptions, + runTimerWorker, + runTimerWorkerWith, +) +where + +import Data.Text qualified as Text +import Data.Time.Clock (NominalDiffTime, diffUTCTime) +import Effectful (Eff, IOE, (:>)) +import Keiro.Prelude +import Keiro.Telemetry ( + KeiroMetrics, + recordTimerAttempts, + recordTimerBacklog, + recordTimerFireLag, + recordTimerRequeued, + recordTimerStuck, + ) +import Keiro.Timer.Schema +import Keiro.Timer.Types +import Kiroku.Store.Effect (Store) +import Kiroku.Store.Types (EventId) + +-- | Options controlling 'runTimerWorkerWith'. +data TimerWorkerOptions = TimerWorkerOptions + { maxAttempts :: Maybe Int + {- ^ When @Just n@, a claimed timer whose post-claim @attempts@ exceeds @n@ is + moved to 'Dead' (via 'deadLetterTimer') instead of being fired. @Nothing@ + never auto-dead-letters (the historical behavior). + -} + , requeueStuckAfter :: !(Maybe NominalDiffTime) + {- ^ When @Just ttl@, each worker pass first moves @Firing@ timers whose + @updated_at@ is at least @ttl@ old back to 'Scheduled'. A fire action that + runs longer than this timeout may be fired again; timer handlers must be + idempotent under keiro's at-least-once timer contract. @Nothing@ disables + automatic requeue for callers that run their own recovery. + -} + } + deriving stock (Generic, Eq, Show) + +data TimerWorkerConfigError + = InvalidTimerMaxAttempts !Int + | InvalidTimerRequeueStuckAfter !NominalDiffTime + deriving stock (Generic, Eq, Show) + +-- | The default worker policy: never auto-dead-letter; requeue stale firings after five minutes. +defaultTimerWorkerOptions :: TimerWorkerOptions +defaultTimerWorkerOptions = TimerWorkerOptions{maxAttempts = Nothing, requeueStuckAfter = Just 300} + +-- | Validate timer worker options before starting a worker loop. +mkTimerWorkerOptions :: TimerWorkerOptions -> Either TimerWorkerConfigError TimerWorkerOptions +mkTimerWorkerOptions opts = + case (opts ^. #maxAttempts, opts ^. #requeueStuckAfter) of + (Just attempts, _) | attempts < 0 -> Left (InvalidTimerMaxAttempts attempts) + (_, Just ttl) | ttl <= 0 -> Left (InvalidTimerRequeueStuckAfter ttl) + _ -> Right opts + +{- | Claim and fire at most one timer due at @now@, applying the given +'TimerWorkerOptions'. + +Atomically claims the earliest due timer (marking it @Firing@). If the options +set @maxAttempts = Just n@ and the timer's post-claim @attempts@ exceeds @n@, it +is dead-lettered ('Dead', with an explanatory @last_error@) instead of fired — +rather than ping-ponging forever on a timer that never completes. Before +claiming, the worker requeues stale @Firing@ rows according to +'requeueStuckAfter'. Otherwise the caller's @fire@ action runs and — if it +returns the id of the event it produced — the timer is marked @Fired@. Returns +the claimed 'TimerRow' (the row as claimed, before any dead-letter or fire +UPDATE), or 'Nothing' when nothing is due. A @fire@ that returns 'Nothing' +leaves the timer @Firing@ until it becomes stale and is requeued on a later +worker pass. + +A timer may fire more than once if a worker crashes after the external action +but before 'markTimerFired', or if @fire@ takes longer than 'requeueStuckAfter'. +Handlers must therefore be idempotent. + +Note 'claimDueTimer' increments @attempts@ before this check, so the comparison +sees the post-claim count: with @maxAttempts = Just 0@ the very first claim +dead-letters; with @Just 2@ the third claim does. +-} +runTimerWorkerWith :: + (IOE :> es, Store :> es) => + Maybe KeiroMetrics -> + TimerWorkerOptions -> + UTCTime -> + (TimerRow -> Eff es (Maybe EventId)) -> + Eff es (Maybe TimerRow) +runTimerWorkerWith metrics options now fire = do + for_ (options ^. #requeueStuckAfter) $ \ttl -> do + requeued <- requeueStuckTimers ttl now + recordTimerRequeued metrics (fromIntegral requeued) + -- Gauges recorded once per pass, before the claim, off the counts the worker + -- already needs its 'Store' for: the backlog as the worker sees it at the + -- start of the pass (including the row it is about to claim), and the number + -- of rows stranded in 'Firing' by earlier passes that never completed. Each + -- is a no-op under a 'Nothing' handle. + backlog <- countDueTimers now + recordTimerBacklog metrics (fromIntegral backlog) + stuck <- countStuckTimers now anyStuckTimer + recordTimerStuck metrics (fromIntegral stuck) + due <- claimDueTimer now + case due of + Nothing -> pure Nothing + Just timer -> do + -- Histograms for the claimed timer: how late it fired and how many + -- attempts it has now taken. EP-33 declared 'keiro.timer.fire.lag' in + -- milliseconds, so the seconds 'diffUTCTime' yields are scaled by 1000. + -- The lag is non-negative because only fire_at <= now rows are claimable. + recordTimerFireLag metrics (realToFrac (now `diffUTCTime` (timer ^. #fireAt)) * 1000) + recordTimerAttempts metrics (fromIntegral (timer ^. #attempts)) + case options ^. #maxAttempts of + Just attemptCeiling + | (timer ^. #attempts) > attemptCeiling -> do + _ <- + deadLetterTimer + (timer ^. #timerId) + ("timer exceeded attempt ceiling of " <> Text.pack (show attemptCeiling)) + pure (Just timer) + _ -> do + fired <- fire timer + for_ fired (\eventId -> void (markTimerFired (timer ^. #timerId) eventId)) + pure (Just timer) + +{- | Claim and fire at most one timer due at @now@ using +'defaultTimerWorkerOptions' (no attempt ceiling). Equivalent to +@'runTimerWorkerWith' 'defaultTimerWorkerOptions'@; the default has no attempt +ceiling and requeues claims left @Firing@ for five minutes. See +'runTimerWorkerWith' for the full semantics. +-} +runTimerWorker :: + (IOE :> es, Store :> es) => + Maybe KeiroMetrics -> + UTCTime -> + (TimerRow -> Eff es (Maybe EventId)) -> + Eff es (Maybe TimerRow) +runTimerWorker metrics = runTimerWorkerWith metrics defaultTimerWorkerOptions diff --git a/src/Keiro/Timer/Schema.hs b/src/Keiro/Timer/Schema.hs new file mode 100644 --- /dev/null +++ b/src/Keiro/Timer/Schema.hs @@ -0,0 +1,457 @@ +{- | The @keiro_timers@ table: storage and claim logic for durable timers. + +Holds one row per scheduled timer with its 'TimerStatus' lifecycle. +'scheduleTimerTx' inserts (or re-arms a still-@Scheduled@ timer with the same +id) inside the caller's transaction; 'claimDueTimer' atomically picks the +single earliest due timer with @FOR UPDATE SKIP LOCKED@ and moves it to +@Firing@, so competing workers never claim the same timer; 'markTimerFired' +records completion and the produced event id. Stale @Firing@ rows are requeued +by 'requeueStuckTimers' so a crashed worker does not strand a timer forever. + +Callers normally use the re-exports from "Keiro.Timer" rather than this +module directly. +-} +module Keiro.Timer.Schema ( + -- * Rows and status + TimerStatus (..), + TimerRow (..), + + -- * Storage + scheduleTimerTx, + scheduleTimerOnceTx, + claimDueTimer, + markTimerFired, + + -- * Read-only counts + countDueTimers, + countStuckTimers, + + -- * Recovery + StuckTimerFilter (..), + anyStuckTimer, + findStuckTimers, + requeueStuckTimers, + requeueStuckTimer, + cancelTimer, + deadLetterTimer, +) +where + +import Contravariant.Extras (contrazip2, contrazip6) +import Data.Time (NominalDiffTime, addUTCTime) +import Data.UUID (UUID) +import Effectful (Eff, (:>)) +import Hasql.Decoders qualified as D +import Hasql.Encoders qualified as E +import Hasql.Statement (Statement, preparable) +import Keiro.Prelude +import Keiro.Timer.Types (TimerId (..), TimerRequest (..)) +import Kiroku.Store.Effect (Store) +import Kiroku.Store.Transaction (runTransaction) +import Kiroku.Store.Types (EventId (..)) +import "hasql-transaction" Hasql.Transaction qualified as Tx + +{- | A timer's lifecycle state. + +* 'Scheduled' — waiting for its 'fireAt'; claimable. +* 'Firing' — claimed by a worker and being processed; stale rows become + claimable again when 'requeueStuckTimers' moves them back to 'Scheduled'. +* 'Fired' — successfully fired; terminal. +* 'Cancelled' — withdrawn before firing. +* 'Dead' — abandoned after exceeding the attempt ceiling; terminal; carries an + optional @last_error@ describing why it was given up on. +-} +data TimerStatus + = Scheduled + | Firing + | Fired + | Cancelled + | Dead + deriving stock (Generic, Eq, Show) + +{- | A timer row as stored: the original 'TimerRequest' fields plus the live +'status', the 'attempts' count (incremented on each claim), and the +'firedEventId' recorded once it fires. +-} +data TimerRow = TimerRow + { timerId :: !TimerId + , processManagerName :: !Text + , correlationId :: !Text + , fireAt :: !UTCTime + , payload :: !Value + , status :: !TimerStatus + , attempts :: !Int + , firedEventId :: !(Maybe EventId) + } + deriving stock (Generic, Eq, Show) + +{- | Criteria selecting timers stranded in 'Firing'. A row is "stuck" when its +'status' is @firing@ and it matches every set bound: 'minAge' (it has been +firing at least this long, measured from @updated_at@) and 'minAttempts' (it +has been claimed at least this many times). Both unset selects every @firing@ +row. +-} +data StuckTimerFilter = StuckTimerFilter + { minAge :: !(Maybe NominalDiffTime) + , minAttempts :: !(Maybe Int) + } + deriving stock (Generic, Eq, Show) + +-- | Select every @firing@ row regardless of age or attempts. +anyStuckTimer :: StuckTimerFilter +anyStuckTimer = StuckTimerFilter Nothing Nothing + +{- | Schedule a timer inside the caller's transaction (typically a process +manager's append). Upserts on 'timerId': a conflicting row is re-armed only +while it is still @Scheduled@, so a timer that has already fired or been +cancelled is not resurrected. +-} +scheduleTimerTx :: TimerRequest -> Tx.Transaction () +scheduleTimerTx request = + Tx.statement + ( timerIdToUuid (request ^. #timerId) + , request ^. #processManagerName + , request ^. #correlationId + , request ^. #fireAt + , request ^. #payload + , statusToText Scheduled + ) + scheduleTimerStmt + +{- | Schedule a timer only if no row with the same 'timerId' already exists. + +This is for callers whose first arm must win, such as durable workflow sleeps: +every resume pass re-runs the sleep arm until the timer fires, and preserving +the original 'fireAt' keeps the sleep measured from the first arm. Process +managers that intentionally push a deadline back should keep using +'scheduleTimerTx'. +-} +scheduleTimerOnceTx :: TimerRequest -> Tx.Transaction () +scheduleTimerOnceTx request = + Tx.statement + ( timerIdToUuid (request ^. #timerId) + , request ^. #processManagerName + , request ^. #correlationId + , request ^. #fireAt + , request ^. #payload + , statusToText Scheduled + ) + scheduleTimerOnceStmt + +{- | Atomically claim the single earliest timer due at @now@, moving it to +@Firing@ and bumping its attempt count. Uses @FOR UPDATE SKIP LOCKED@ so +concurrent workers each get a distinct timer. Returns 'Nothing' when none is +due. +-} +claimDueTimer :: (Store :> es) => UTCTime -> Eff es (Maybe TimerRow) +claimDueTimer now = + runTransaction $ + Tx.statement now claimDueTimerStmt + +{- | Mark a claimed timer @Fired@, recording the id of the event its firing +produced. Returns 'False' when the row left @Firing@ while the fire action was +running (for example, it was requeued, cancelled, or dead-lettered). +-} +markTimerFired :: (Store :> es) => TimerId -> EventId -> Eff es Bool +markTimerFired timerId eventId = + runTransaction $ + Tx.statement (timerIdToUuid timerId, eventIdToUuid eventId) markTimerFiredStmt + +{- | Count timers that are @scheduled@ and already due at @now@ — the timer +backlog. Read-only; mirrors 'claimDueTimer''s WHERE clause but counts rather +than locking, so it never claims or mutates a row. +-} +countDueTimers :: (Store :> es) => UTCTime -> Eff es Int +countDueTimers now = + runTransaction $ + Tx.statement now countDueTimersStmt + +{- | Count timers stranded in @Firing@ that match the given 'StuckTimerFilter' — +the same "stuck" predicate 'findStuckTimers' lists, evaluated against @now@. +Read-only. 'anyStuckTimer' counts every @firing@ row. +-} +countStuckTimers :: (Store :> es) => UTCTime -> StuckTimerFilter -> Eff es Int +countStuckTimers now stuckFilter = + runTransaction $ + Tx.statement (cutoff, fmap fromIntegral (stuckFilter ^. #minAttempts)) countStuckTimersStmt + where + cutoff = fmap (\age -> addUTCTime (negate age) now) (stuckFilter ^. #minAge) + +{- | List timers stranded in @Firing@ that match the given 'StuckTimerFilter'. +The @minAge@ bound is evaluated against @now@: a row qualifies when its +@updated_at@ is at least @minAge@ in the past (cutoff @now - minAge@). Results +are ordered oldest-first by @updated_at@. +-} +findStuckTimers :: + (Store :> es) => UTCTime -> StuckTimerFilter -> Eff es [TimerRow] +findStuckTimers now stuckFilter = + runTransaction $ + Tx.statement (cutoff, fmap fromIntegral (stuckFilter ^. #minAttempts)) findStuckTimersStmt + where + cutoff = fmap (\age -> addUTCTime (negate age) now) (stuckFilter ^. #minAge) + +{- | Move every timer stranded in @Firing@ for at least @olderThan@ back to +@Scheduled@. The statement preserves @fire_at@, so a due timer becomes +claimable on the same worker pass. Returns the number of rows requeued. +-} +requeueStuckTimers :: (Store :> es) => NominalDiffTime -> UTCTime -> Eff es Int +requeueStuckTimers olderThan now = + runTransaction $ + Tx.statement cutoff requeueStuckTimersStmt + where + cutoff = addUTCTime (negate olderThan) now + +{- | Move a timer from @Firing@ back to @Scheduled@ so the ordinary claim loop +re-fires it. Leaves @fire_at@ unchanged, so a due timer becomes immediately +re-claimable. Idempotent: only @firing@ rows match, so re-running on an +already-requeued row affects nothing. Returns 'True' when a row changed. +-} +requeueStuckTimer :: (Store :> es) => TimerId -> Eff es Bool +requeueStuckTimer timerId = + runTransaction $ + Tx.statement (timerIdToUuid timerId) requeueStuckTimerStmt + +{- | Move a timer from @Scheduled@ or @Firing@ to the terminal @Cancelled@ +state so it never fires. Terminal rows (@fired@, @cancelled@, @dead@) are left +untouched. Idempotent. Returns 'True' when a row changed. +-} +cancelTimer :: (Store :> es) => TimerId -> Eff es Bool +cancelTimer timerId = + runTransaction $ + Tx.statement (timerIdToUuid timerId) cancelTimerStmt + +{- | Move a timer from @Scheduled@ or @Firing@ to the terminal @Dead@ state, +recording @reason@ in @last_error@ so an operator can see why it was abandoned +(@SELECT * FROM keiro_timers WHERE status = 'dead'@). Terminal rows are left +untouched. Idempotent. Returns 'True' when a row changed. +-} +deadLetterTimer :: (Store :> es) => TimerId -> Text -> Eff es Bool +deadLetterTimer timerId reason = + runTransaction $ + Tx.statement (timerIdToUuid timerId, reason) deadLetterTimerStmt + +scheduleTimerStmt :: Statement (UUID, Text, Text, UTCTime, Value, Text) () +scheduleTimerStmt = + preparable + """ + INSERT INTO keiro.keiro_timers + (timer_id, process_manager_name, correlation_id, fire_at, payload, status) + VALUES + ($1, $2, $3, $4, $5, $6) + ON CONFLICT (timer_id) DO UPDATE + SET process_manager_name = EXCLUDED.process_manager_name, + correlation_id = EXCLUDED.correlation_id, + fire_at = EXCLUDED.fire_at, + payload = EXCLUDED.payload, + status = EXCLUDED.status, + updated_at = now() + WHERE keiro_timers.status = 'scheduled' + """ + ( contrazip6 + (E.param (E.nonNullable E.uuid)) + (E.param (E.nonNullable E.text)) + (E.param (E.nonNullable E.text)) + (E.param (E.nonNullable E.timestamptz)) + (E.param (E.nonNullable E.jsonb)) + (E.param (E.nonNullable E.text)) + ) + D.noResult + +scheduleTimerOnceStmt :: Statement (UUID, Text, Text, UTCTime, Value, Text) () +scheduleTimerOnceStmt = + preparable + """ + INSERT INTO keiro.keiro_timers + (timer_id, process_manager_name, correlation_id, fire_at, payload, status) + VALUES + ($1, $2, $3, $4, $5, $6) + ON CONFLICT (timer_id) DO NOTHING + """ + ( contrazip6 + (E.param (E.nonNullable E.uuid)) + (E.param (E.nonNullable E.text)) + (E.param (E.nonNullable E.text)) + (E.param (E.nonNullable E.timestamptz)) + (E.param (E.nonNullable E.jsonb)) + (E.param (E.nonNullable E.text)) + ) + D.noResult + +claimDueTimerStmt :: Statement UTCTime (Maybe TimerRow) +claimDueTimerStmt = + preparable + """ + WITH due AS ( + SELECT timer_id + FROM keiro.keiro_timers + WHERE status = 'scheduled' + AND fire_at <= $1 + ORDER BY fire_at, timer_id + LIMIT 1 + FOR UPDATE SKIP LOCKED + ) + UPDATE keiro.keiro_timers kt + SET status = 'firing', + attempts = kt.attempts + 1, + updated_at = now() + FROM due + WHERE kt.timer_id = due.timer_id + RETURNING kt.timer_id, kt.process_manager_name, kt.correlation_id, kt.fire_at, + kt.payload, kt.status, kt.attempts, kt.fired_event_id + """ + (E.param (E.nonNullable E.timestamptz)) + (D.rowMaybe timerRowDecoder) + +markTimerFiredStmt :: Statement (UUID, UUID) Bool +markTimerFiredStmt = + preparable + """ + UPDATE keiro.keiro_timers + SET status = 'fired', + fired_event_id = $2, + updated_at = now() + WHERE timer_id = $1 + AND status = 'firing' + """ + ( contrazip2 + (E.param (E.nonNullable E.uuid)) + (E.param (E.nonNullable E.uuid)) + ) + ((> 0) <$> D.rowsAffected) + +countDueTimersStmt :: Statement UTCTime Int +countDueTimersStmt = + preparable + """ + SELECT count(*) + FROM keiro.keiro_timers + WHERE status = 'scheduled' + AND fire_at <= $1 + """ + (E.param (E.nonNullable E.timestamptz)) + (D.singleRow (fromIntegral <$> D.column (D.nonNullable D.int8))) + +countStuckTimersStmt :: Statement (Maybe UTCTime, Maybe Int64) Int +countStuckTimersStmt = + preparable + """ + SELECT count(*) + FROM keiro.keiro_timers + WHERE status = 'firing' + AND ($1::timestamptz IS NULL OR updated_at <= $1) + AND ($2::bigint IS NULL OR attempts >= $2) + """ + ( contrazip2 + (E.param (E.nullable E.timestamptz)) + (E.param (E.nullable E.int8)) + ) + (D.singleRow (fromIntegral <$> D.column (D.nonNullable D.int8))) + +findStuckTimersStmt :: Statement (Maybe UTCTime, Maybe Int64) [TimerRow] +findStuckTimersStmt = + preparable + """ + SELECT timer_id, process_manager_name, correlation_id, fire_at, + payload, status, attempts, fired_event_id + FROM keiro.keiro_timers + WHERE status = 'firing' + AND ($1::timestamptz IS NULL OR updated_at <= $1) + AND ($2::bigint IS NULL OR attempts >= $2) + ORDER BY updated_at, timer_id + """ + ( contrazip2 + (E.param (E.nullable E.timestamptz)) + (E.param (E.nullable E.int8)) + ) + (D.rowList timerRowDecoder) + +requeueStuckTimersStmt :: Statement UTCTime Int +requeueStuckTimersStmt = + preparable + """ + UPDATE keiro.keiro_timers + SET status = 'scheduled', + updated_at = now() + WHERE status = 'firing' + AND updated_at <= $1 + """ + (E.param (E.nonNullable E.timestamptz)) + (fromIntegral <$> D.rowsAffected) + +requeueStuckTimerStmt :: Statement UUID Bool +requeueStuckTimerStmt = + preparable + """ + UPDATE keiro.keiro_timers + SET status = 'scheduled', + updated_at = now() + WHERE timer_id = $1 + AND status = 'firing' + """ + (E.param (E.nonNullable E.uuid)) + ((> 0) <$> D.rowsAffected) + +cancelTimerStmt :: Statement UUID Bool +cancelTimerStmt = + preparable + """ + UPDATE keiro.keiro_timers + SET status = 'cancelled', + updated_at = now() + WHERE timer_id = $1 + AND status IN ('scheduled', 'firing') + """ + (E.param (E.nonNullable E.uuid)) + ((> 0) <$> D.rowsAffected) + +deadLetterTimerStmt :: Statement (UUID, Text) Bool +deadLetterTimerStmt = + preparable + """ + UPDATE keiro.keiro_timers + SET status = 'dead', + last_error = $2, + updated_at = now() + WHERE timer_id = $1 + AND status IN ('scheduled', 'firing') + """ + ( contrazip2 + (E.param (E.nonNullable E.uuid)) + (E.param (E.nonNullable E.text)) + ) + ((> 0) <$> D.rowsAffected) + +timerRowDecoder :: D.Row TimerRow +timerRowDecoder = + TimerRow + <$> (TimerId <$> D.column (D.nonNullable D.uuid)) + <*> D.column (D.nonNullable D.text) + <*> D.column (D.nonNullable D.text) + <*> D.column (D.nonNullable D.timestamptz) + <*> D.column (D.nonNullable D.jsonb) + <*> D.column (D.nonNullable (D.refine statusFromText D.text)) + <*> (fromIntegral <$> D.column (D.nonNullable D.int8)) + <*> (fmap EventId <$> D.column (D.nullable D.uuid)) + +statusToText :: TimerStatus -> Text +statusToText = \case + Scheduled -> "scheduled" + Firing -> "firing" + Fired -> "fired" + Cancelled -> "cancelled" + Dead -> "dead" + +statusFromText :: Text -> Either Text TimerStatus +statusFromText = \case + "scheduled" -> Right Scheduled + "firing" -> Right Firing + "fired" -> Right Fired + "cancelled" -> Right Cancelled + "dead" -> Right Dead + other -> Left ("unknown keiro_timers.status: " <> other) + +timerIdToUuid :: TimerId -> UUID +timerIdToUuid (TimerId uuid) = uuid + +eventIdToUuid :: EventId -> UUID +eventIdToUuid (EventId uuid) = uuid diff --git a/src/Keiro/Timer/Types.hs b/src/Keiro/Timer/Types.hs new file mode 100644 --- /dev/null +++ b/src/Keiro/Timer/Types.hs @@ -0,0 +1,35 @@ +{- | Identity and request types for durable timers, separated from their SQL +storage ("Keiro.Timer.Schema") so process-manager code can construct timer +requests without depending on the persistence layer. +-} +module Keiro.Timer.Types ( + TimerId (..), + TimerRequest (..), +) +where + +import Data.UUID (UUID) +import Keiro.Prelude + +{- | A timer's stable identifier. A caller-chosen id makes scheduling +idempotent (rescheduling the same id updates rather than duplicates). +-} +newtype TimerId = TimerId UUID + deriving stock (Generic, Eq, Ord, Show) + +{- | A request to schedule a timer. + +* 'timerId' — stable id; rescheduling the same id is idempotent. +* 'processManagerName' \/ 'correlationId' — identify the saga instance the + timer belongs to, so the firing can be routed back to it. +* 'fireAt' — the earliest time the timer becomes due. +* 'payload' — opaque JSON carried through to the @fire@ action. +-} +data TimerRequest = TimerRequest + { timerId :: !TimerId + , processManagerName :: !Text + , correlationId :: !Text + , fireAt :: !UTCTime + , payload :: !Value + } + deriving stock (Generic, Eq, Show) diff --git a/src/Keiro/Wake.hs b/src/Keiro/Wake.hs new file mode 100644 --- /dev/null +++ b/src/Keiro/Wake.hs @@ -0,0 +1,112 @@ +{- | A wake signal for keiro's poll-loop workers (EP-50, LISTEN/NOTIFY push delivery). + +keiro's background workers — the workflow resume worker, the durable-timer worker, +the outbox publisher — make progress by polling: run one "claim, process, commit" +pass, then sleep a fixed interval. That fixed sleep is also the worst-case latency +(the resume worker's default is a full second). This module lets a worker instead +/wait to be woken/: it blocks until either a relevant append notification arrives — +meaning "something was appended, go look" — or a bounded fallback timeout elapses. + +== Where the wake comes from (no new connection) + +The kiroku event store already fires a Postgres @NOTIFY@ on channel @\.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 +(@\.events@; @stream_name,stream_id,stream_version@); keiro treats the +notification as an opaque wake and re-queries durably, so it ignores the payload. +-} +module Keiro.Wake ( + WakeSignal (..), + WakeReason (..), + wakeSignalFromStore, + neverWake, +) +where + +import Control.Concurrent.STM ( + TChan, + atomically, + check, + dupTChan, + isEmptyTChan, + orElse, + readTChan, + readTVar, + registerDelay, + ) +import Kiroku.Store.Connection (KirokuStore (..)) +import Kiroku.Store.Notification (Notifier (..)) + +{- | Why a 'waitForWake' returned: a notification arrived, or the fallback timeout +elapsed. Both mean "run another pass"; the distinction is available for telemetry. +-} +data WakeReason = WokenByNotify | WokenByTimeout + deriving stock (Eq, Show) + +{- | A source of "something was appended, go look" wake-ups, layered over a bounded +fallback timeout so a missed notification never stalls progress. +-} +newtype WakeSignal = WakeSignal + { waitForWake :: Int -> IO WakeReason + {- ^ Block until a notification arrives OR the given fallback timeout + (microseconds) elapses, whichever is first. Returns which happened. + -} + } + +{- | Build a 'WakeSignal' from a running kiroku store's notifier. Duplicates the +store's broadcast tick channel ('dupTChan') __once__ here, so this consumer has its +own cursor and never steals another consumer's ticks, and so ticks arriving between +waits queue in the duplicated channel rather than being lost. Opens __no__ new +database connection: it rides the single dedicated listener connection the store +already holds. +-} +wakeSignalFromStore :: KirokuStore -> IO WakeSignal +wakeSignalFromStore store = do + myChan <- atomically (dupTChan (tickChan (notifier store))) + pure (WakeSignal (waitOn myChan)) + where + waitOn :: TChan () -> Int -> IO WakeReason + waitOn myChan timeoutMicros = do + timer <- registerDelay timeoutMicros + atomically $ + ( do + -- A tick is queued: collapse any backlog so one wait returns once per + -- "there is new work" episode (the worker re-queries durably anyway). + _ <- readTChan myChan + drain myChan + pure WokenByNotify + ) + `orElse` (readTVar timer >>= check >> pure WokenByTimeout) + + drain ch = do + empty <- isEmptyTChan ch + if empty then pure () else readTChan ch >> drain ch + +{- | A 'WakeSignal' that never fires a notification — every wait elapses the fallback +timeout. Used to simulate "all NOTIFYs dropped" (proving push is an optimization over +the durable poll) and to give a fixed-poll worker an unchanged cadence under the same +push-aware driver. +-} +neverWake :: WakeSignal +neverWake = WakeSignal $ \timeoutMicros -> do + timer <- registerDelay timeoutMicros + atomically (readTVar timer >>= check) + pure WokenByTimeout diff --git a/src/Keiro/Workflow.hs b/src/Keiro/Workflow.hs new file mode 100644 --- /dev/null +++ b/src/Keiro/Workflow.hs @@ -0,0 +1,948 @@ +{-# LANGUAGE TypeFamilies #-} + +{- | The durable workflow runtime: the @Workflow@ effect, named-step +journaling, replay, and suspension. + +== What this gives you + +Write a long-running process as an ordinary @effectful@ computation and run +it with 'runWorkflow'. Each @'step' name action@ either runs @action@ and +records ("journals") its result, or — on a replay after a crash — returns the +previously recorded result /without/ re-running the side effect. The journal +is a kiroku stream named @wf:\-\@ ('workflowStreamName'); there is +no separate history table. Because a workflow can pause (waiting for a timer, +an external signal, or a child), 'runWorkflow' returns a 'WorkflowOutcome' +('Completed' or 'Suspended'). + +Step side effects are at-least-once across process crashes. If the process +crashes after @action@ runs but before the journal append commits, a later +resume has no record of that step and runs @action@ again. Step bodies that call +external systems must therefore be idempotent, typically by deriving an +idempotency key from the workflow identity and step name and passing it to the +external system. + +Replay is keyed by step name, not by source position or code identity. Renaming +a step intentionally orphans the old journal entry and runs the renamed step as +new work; changing the meaning of a step while keeping the same name is the +author's responsibility. Use 'patch' for cross-cutting workflow-body changes +that need an explicit old/new branch. + +== Contract recap for downstream plans (the v2 MasterPlan) + +* The authoring surface is the @Workflow@ effect with 'step', 'awaitStep', + 'currentWorkflow', and 'freshOrdinal'. Add new primitives (sleep, + awakeable, child) as functions that go /through/ this effect so a single + import stays the workflow surface. +* 'awaitStep' is the suspension primitive every wake source builds on: it + returns a journaled result if present, otherwise runs an idempotent + /arming/ action once and suspends the run. The arming action MUST be + idempotent — a suspended-then-resumed workflow re-enters 'awaitStep' from + the top on every resume until the result is journaled, so it re-runs @arm@ + each time (e.g. schedule a timer with a deterministic id so repeats + collapse to a no-op). +* A wake source's external completion path (a timer firing, + @signalAwakeable@, a child finishing) calls 'appendJournalEntry' (or + 'appendJournalEntryReturningId') with a 'StepRecorded' whose @stepName@ is + the awaited step name; the next 'runWorkflow' then takes the 'awaitStep' + hit path and proceeds. +* The journal codec ('workflowJournalCodec') and the reserved step-name + prefixes ('sleepStepPrefix' = @"sleep:"@, 'awakeableStepPrefix' = @"awk:"@, + 'childStepPrefix' = @"child:"@) are integration contracts: suspensions are + journaled as ordinary 'StepRecorded' events with these prefixes, never as + new event types, so the replay loop stays uniform. +* Per-run options live in one record, 'WorkflowRunOptions' (EP-41 adds a + snapshot policy, EP-44 adds metrics/tracer); 'runWorkflowWith' is the + single canonical entry EP-42's resume worker re-invokes through. +* The derived @keiro_workflows@ instance row is maintained by journal append + transactions. Terminal markers ('WorkflowCompleted', 'WorkflowCancelled', + 'WorkflowFailed') freeze the instance as completed/cancelled/failed, and the + resume worker uses its attempt/lease fields for crash recovery. +* Discovery (EP-42) is 'findUnfinishedWorkflowIds' plus 'completedStepName'; + it needs no kiroku prefix subscription. + +> __Build gotcha__ (EP-38's migration adds @keiro_workflow_steps@): adding a +> new @.sql@ file under @keiro-migrations/sql-migrations/@ does not trigger +> recompilation of @Keiro.Migrations@ (cabal says "Up to date" even with +> @-fforce-recomp@, because @embedDir@ is a Template Haskell directory read +> GHC's recompilation checker does not track per-file). After adding a +> migration, edit a comment in @keiro-migrations/src/Keiro/Migrations.hs@ or +> run @cabal clean@ before building. +-} +module Keiro.Workflow ( + -- * The effect and authoring surface + Workflow, + step, + awaitStep, + currentWorkflow, + currentRunGeneration, + freshOrdinal, + continueAsNew, + restoreSeed, + patch, + + -- * Running a workflow + runWorkflow, + runWorkflowWith, + WorkflowRunOptions (..), + defaultWorkflowRunOptions, + + -- * Journal append helpers (used by wake-source plans) + JournalAppendOutcome (..), + prepareJournalAppend, + appendJournalEntry, + appendJournalEntryReturningId, + + -- * Errors thrown by the runtime + WorkflowError (..), + + -- * Re-exported core contracts + module Keiro.Workflow.Types, + WorkflowStepRow (..), + recordStepTx, + loadStepIndex, + stepExists, + currentGeneration, + findUnfinishedWorkflowIds, + setWorkflowWakeAfterTx, +) +where + +import Control.Exception (Exception) +import Data.Aeson qualified as Aeson +import Data.IORef ( + IORef, + atomicModifyIORef', + newIORef, + readIORef, + ) +import Data.Int (Int32) +import Data.Map.Strict (Map) +import Data.Map.Strict qualified as Map +import Data.Set (Set) +import Data.Set qualified as Set +import Data.Text qualified as Text +import Data.UUID.V5 qualified as UUID.V5 +import Effectful (Dispatch (..), DispatchOf, Eff, Effect, IOE, (:>)) +import Effectful.Dispatch.Dynamic (EffectHandler, interpret, localSeqUnlift, send) +import Effectful.Error.Static (Error, tryError) +import Effectful.Exception (bracket_, catch, throwIO) +import Keiro.Codec (decodeRecorded, encodeForAppendWithMetadata) +import Keiro.EventStream (SnapshotPolicy (..), Terminality (..)) +import Keiro.Prelude +import Keiro.Snapshot (SnapshotMissReason (..)) +import Keiro.Snapshot.Policy (shouldSnapshot) +import Keiro.Telemetry ( + KeiroMetrics, + Tracer, + recordSnapshotDecodeFailures, + recordSnapshotReadHits, + recordSnapshotReadMisses, + recordSnapshotWriteFailures, + recordWorkflowActive, + recordWorkflowJournalLength, + recordWorkflowStepExecuted, + recordWorkflowStepReplayed, + withWorkflowSpan, + ) +import Keiro.Workflow.Instance ( + WorkflowStatus (..), + markInstanceSuspended, + upsertInstanceTx, + ) +import Keiro.Workflow.Schema (WorkflowStepRow (..), currentGeneration, findUnfinishedWorkflowIds, loadStepIndex, lockWorkflowStepTx, lookupStepResultTx, recordStepTx, setWorkflowWakeAfterTx, stepExists) +import Keiro.Workflow.Snapshot (lookupWorkflowSnapshot, writeWorkflowSnapshot) +import Keiro.Workflow.Types +import Kiroku.Store.Effect (Store) +import Kiroku.Store.Error (StoreError) +import Kiroku.Store.Read (readStreamForwardStream) +import Kiroku.Store.Transaction (AppendConflict, appendToStreamTx, prepareEventsIO, runTransaction) +import Kiroku.Store.Types (AppendResult (..), EventData, EventId (..), ExpectedVersion (..), StreamId, StreamVersion (..)) +import Streamly.Data.Fold qualified as Fold +import Streamly.Data.Stream qualified as Streamly +import System.IO.Unsafe (unsafePerformIO) +import "hasql-transaction" Hasql.Transaction qualified as Tx + +-- --------------------------------------------------------------------------- +-- The effect +-- --------------------------------------------------------------------------- + +{- | The durable workflow effect. Its operations are interpreted by +'runWorkflow' / 'runWorkflowWith', which journal and replay them. +-} +data Workflow :: Effect where + {- | Run a side-effecting action under a name, journaling its result; on + replay, return the recorded result without re-running the action. + -} + Step :: (Aeson.ToJSON a, Aeson.FromJSON a) => StepName -> m a -> Workflow m a + {- | Return the awaited step's journaled result, or run the (idempotent) + arming action once and suspend the run. + -} + Await :: (Aeson.FromJSON a) => StepName -> m () -> Workflow m a + -- | The running workflow's identity (for keying wake sources). + CurrentWorkflow :: Workflow m (WorkflowName, WorkflowId) + -- | The journal generation this run is operating on. + CurrentRunGeneration :: Workflow m Int + -- | A per-run, per-namespace counter for deterministic ordinal step names. + FreshOrdinal :: Text -> Workflow m Int + {- | EP-48: snapshot the carried seed, rotate onto a fresh journal generation, + and unwind this run; the next run/resume continues from the seed. Never + returns to the caller within this run (result type is fully polymorphic). + -} + ContinueAsNew :: (Aeson.ToJSON s) => s -> Workflow m a + {- | EP-49: decide and journal a cross-cutting branch — returns the stable + 'Bool' branch decision for the given patch. Fresh instances get 'True' + (new branch); instances already in flight when the patch shipped get + 'False' (old branch). The decision is journaled on first encounter and + replayed verbatim thereafter. + -} + Patch :: PatchId -> Workflow m Bool + +type instance DispatchOf Workflow = Dynamic + +{- | Run @action@ under @name@, journaling its encoded result. On a replay where +@name@ is already journaled, the recorded result is returned and @action@ is +not run. If the process crashed after @action@ ran but before the journal +commit, the action runs again on resume: workflow step side effects are +at-least-once at the step boundary. + +The returned value is always the JSON round-trip of the recorded result, +including on the first run. A lossy or rejecting @ToJSON@\/@FromJSON@ pair is +therefore observed immediately rather than only after a crash and replay. + +Requires @'Aeson.ToJSON' a@ (to journal the result) and @'Aeson.FromJSON' a@ +(to decode it on replay). +-} +step :: (Workflow :> es, Aeson.ToJSON a, Aeson.FromJSON a) => StepName -> Eff es a -> Eff es a +step name action = send (Step name action) + +{- | Look up @name@ in the journal. If a wake source has already recorded its +completion (a 'StepRecorded' whose @stepName@ is @name@, carrying the +resolved result), decode and return it. Otherwise run @arm@ exactly once +(the wake source's idempotent job — schedule a timer, register an awakeable, +spawn a child) and __suspend__ this run, so 'runWorkflow' returns 'Suspended'. + +@arm@ must be idempotent: every resume re-runs it until the result is +journaled. +-} +awaitStep :: (Workflow :> es, Aeson.FromJSON a) => StepName -> Eff es () -> Eff es a +awaitStep name arm = send (Await name arm) + +-- | The identity of the workflow currently running. +currentWorkflow :: (Workflow :> es) => Eff es (WorkflowName, WorkflowId) +currentWorkflow = send CurrentWorkflow + +{- | The journal generation this run is operating on. Wake sources include it +in their durable identities so a generation opened by 'continueAsNew' never +collides with prior-generation rows. +-} +currentRunGeneration :: (Workflow :> es) => Eff es Int +currentRunGeneration = send CurrentRunGeneration + +{- | A per-run, per-namespace counter (starting at 0). Used by convenience +forms of wake sources (e.g. @sleep@ → @"sleep:0"@) to derive a deterministic, +replay-stable ordinal name. Note: ordinal names are only stable if the order +of @awaitStep@-style calls does not change across deploys; the named forms +are the stable primitives. +-} +freshOrdinal :: (Workflow :> es) => Text -> Eff es Int +freshOrdinal namespace = send (FreshOrdinal namespace) + +{- | Continue this workflow /as new/ (EP-48): snapshot the carried @seed@ onto a +fresh journal generation, journal a terminal rotation marker on the current +generation, and unwind this run. The next run or resume of the same logical +@('WorkflowName', 'WorkflowId')@ starts against the fresh generation, hydrated +from the seed, with an empty (bounded) journal. + +This is how a workflow that runs an /unbounded/ number of steps — a poller, a +per-day rolling process — keeps its per-generation journal bounded so replay +and hydration stay fast forever. The result type is fully polymorphic (@a@) +because control never returns to the caller within /this/ run: the rotated +continuation runs in the next run/resume. Read the carried seed back at the top +of the workflow body with 'restoreSeed'. +-} +continueAsNew :: (Workflow :> es, Aeson.ToJSON s) => s -> Eff es a +continueAsNew seed = send (ContinueAsNew seed) + +{- | Restore the seed carried by the previous generation's 'continueAsNew', or +return @def@ on the first generation (EP-48). Implemented as an ordinary +journaled @step@ under the reserved 'continueSeedStepName': on a generation that +was rotated into, the seed step was journaled (and snapshotted) by the rotation, +so this @step@ hits it and returns the carried value without re-running; on the +very first generation it misses and records @def@. Call it once at the top of a +workflow body that uses 'continueAsNew'. +-} +restoreSeed :: (Workflow :> es, Aeson.ToJSON s, Aeson.FromJSON s) => s -> Eff es s +restoreSeed def = step (StepName continueSeedStepName) (pure def) + +{- | Decide a cross-cutting branch for an in-flight-vs-fresh code change, and +journal the decision so every later replay observes the same branch (EP-49). + +@patch (PatchId "fraud-check-v2")@ returns 'True' only when that id was present +in 'activePatches' when this workflow generation first started. The generation +records its active set under 'patchSetStepName' exactly once; on the first +encounter each individual patch decision is journaled under @patch:\@, +and every replay returns the recorded 'Bool'. Add a patch id to 'activePatches' +in the deploy that introduces the corresponding 'patch' call; remove it only +after deleting that call from the workflow body. + +This is an /escape hatch/ for changes that cross-cut multiple steps. For the +common case — one step changed — do __not__ use 'patch': rename the step's +'StepName' instead. A renamed step has no journaled history under its new name, +so its action runs fresh on the next replay, which is exactly the right +behaviour for a single-step change. Reach for 'patch' only when an in-flight +instance would be left incoherent by the new code (e.g. the change adds, removes, +or reorders steps, or changes the meaning of an already-journaled step result). +-} +patch :: (Workflow :> es) => PatchId -> Eff es Bool +patch pid = send (Patch pid) + +-- --------------------------------------------------------------------------- +-- Per-run options +-- --------------------------------------------------------------------------- + +{- | Options for a single workflow run. This is the canonical home for +per-run options across the v2 initiative — EP-41 adds the snapshot policy, +EP-44 adds metrics/tracer fields, all additive. Extend it additively; never +break the field set EP-38/EP-41 established. +-} +data WorkflowRunOptions = WorkflowRunOptions + { snapshotPolicy :: !(SnapshotPolicy WorkflowState) + {- ^ When to persist a snapshot of the accumulated step-result map after a + step append (and at completion, for 'OnTerminal'). Default 'Never' + (EP-38 behaviour: every run/resume does a full version-0 replay). + -} + , pageSize :: !Int32 + -- ^ Page size for the journal pre-load read. + , metrics :: !(Maybe KeiroMetrics) + {- ^ EP-44: when 'Just', the runtime records the @keiro.workflow.*@ instruments + (steps executed/replayed, active count, journal length). 'Nothing' is the + no-op default, so a run with 'defaultWorkflowRunOptions' records nothing. + -} + , tracer :: !(Maybe Tracer) + {- ^ EP-44: when 'Just', the runtime opens a @workflow \@ 'Internal' span + around the run. 'Nothing' runs the body unwrapped. + -} + , activePatches :: !(Set PatchId) + {- ^ Patch ids currently active in this deployed workflow code. A fresh + workflow generation records this set once under 'patchSetStepName', and + each 'patch' call returns 'True' iff its id was in that recorded set. + -} + } + deriving stock (Generic) + +{- | Sensible defaults: no snapshotting, a journal pre-load page size of 100, +and no telemetry (metrics/tracer 'Nothing'). A default-options run replays +and behaves exactly as EP-38 did. +-} +defaultWorkflowRunOptions :: WorkflowRunOptions +defaultWorkflowRunOptions = + WorkflowRunOptions + { snapshotPolicy = Never + , pageSize = 100 + , metrics = Nothing + , tracer = Nothing + , activePatches = Set.empty + } + +-- --------------------------------------------------------------------------- +-- Errors and the suspension sentinel +-- --------------------------------------------------------------------------- + +{- | Errors the workflow runtime raises (via 'throwIO', so they surface +through the surrounding store/IO error channel). +-} +data WorkflowError + = {- | A journaled step result could not be decoded into the type the + replaying @step@/@awaitStep@ expects (step name, decode message). The + result type changed incompatibly — a programmer error. + -} + WorkflowStepDecodeError !Text !Text + | -- | A journal event could not be decoded during pre-load. + WorkflowJournalDecodeError !Text + | -- | A journal event could not be encoded for append. + WorkflowJournalEncodeError !Text + | -- | Appending a journal entry failed for a non-conflict reason. + WorkflowJournalAppendError !Text + deriving stock (Eq, Show) + +instance Exception WorkflowError + +-- | Internal sentinel thrown to unwind a suspended run up to 'runWorkflowWith'. +data WorkflowSuspend = WorkflowSuspend + deriving stock (Show) + +instance Exception WorkflowSuspend + +-- | Internal sentinel thrown when a cancellation marker appears mid-run. +data WorkflowCancelPending = WorkflowCancelPending + deriving stock (Show) + +instance Exception WorkflowCancelPending + +{- | Internal sentinel thrown by the 'ContinueAsNew' handler to unwind a +rotating run up to 'runWorkflowWith' (EP-48), carrying the JSON-encoded seed for +the next generation. Mirrors 'WorkflowSuspend': a non-returning unwind the run +entry point catches and turns into an outcome ('ContinuedAsNew'). +-} +newtype WorkflowRotate = WorkflowRotate Aeson.Value + deriving stock (Show) + +instance Exception WorkflowRotate + +-- --------------------------------------------------------------------------- +-- Running +-- --------------------------------------------------------------------------- + +{- | Process-wide count of workflow runs currently in flight, backing the +@keiro.workflow.active@ gauge (EP-44). 'runWorkflowWith' brackets each run with +@+1@/@-1@ and samples the gauge on both edges, so the exported last-value +reflects the true live count whether a run is mid-flight or finished. A +process-global 'IORef' is the lightest faithful implementation (the gauge is a +last-value-wins level, not a per-run delta), mirroring how the other keiro +backlog/level gauges are recorded with a value the runtime already holds. +-} +{-# NOINLINE activeCountRef #-} +activeCountRef :: IORef Int64 +activeCountRef = unsafePerformIO (newIORef 0) + +{- | Run a workflow computation, journaling each 'step' and replaying any +already-journaled steps. Returns 'Completed' when the computation finishes +(a 'WorkflowCompleted' marker is journaled) or 'Suspended' when it pauses at +an unresolved 'awaitStep'. + +Equivalent to @'runWorkflowWith' 'defaultWorkflowRunOptions'@. +-} +runWorkflow :: + (IOE :> es, Store :> es, Error StoreError :> es) => + WorkflowName -> + WorkflowId -> + Eff (Workflow : es) a -> + Eff es (WorkflowOutcome a) +runWorkflow = runWorkflowWith defaultWorkflowRunOptions + +{- | 'runWorkflow' with explicit 'WorkflowRunOptions'. This is the single +canonical run entry point; EP-42's resume worker re-invokes through it so +resumed runs honor the same options. + +If the workflow's journal already carries a 'WorkflowCancelled' marker (a child +cancelled by its parent, EP-43), the run short-circuits immediately and returns +'Cancelled' without executing any step. The handler also re-checks that marker +on step/await/patch miss paths and after a fresh step action returns, so a +mid-run cancellation stops at the next workflow boundary. A cancellation that +lands after the check but before/during the user action may still let that one +action run; durable workflow steps remain at-least-once at boundaries. If the +journal carries a 'WorkflowFailed' marker, the run likewise short-circuits to +'Failed'. To /propagate/ a finished child's result to its parent, drive the +child through 'Keiro.Workflow.Child.runChildWorkflow' rather than this function +directly. +-} +runWorkflowWith :: + forall a es. + (IOE :> es, Store :> es, Error StoreError :> es) => + WorkflowRunOptions -> + WorkflowName -> + WorkflowId -> + Eff (Workflow : es) a -> + Eff es (WorkflowOutcome a) +runWorkflowWith options name wid action = do + -- EP-48: resolve the CURRENT (highest) generation once per run and operate + -- only on it. A never-rotating workflow stays at generation 0, so naming, + -- load, and append are byte-for-byte as before. A rotated workflow resolves + -- to its newest generation, so discovery/resume transparently continue there. + gen <- currentGeneration name wid + -- Cancellation short-circuit (EP-43): a workflow whose journal carries a + -- WorkflowCancelled marker makes no further progress. The index row for that + -- marker is keyed under 'cancelledStepName' on the current generation, so a + -- single existence check is enough and we never run the user action. + cancelled <- stepExists name wid gen cancelledStepName + failed <- stepExists name wid gen failedStepName + case (cancelled, failed) of + (True, _) -> pure Cancelled + (_, True) -> pure Failed + _ -> runActive gen + where + -- EP-44 telemetry handles, pulled from the run options once. Both default + -- to 'Nothing' (see 'defaultWorkflowRunOptions'), so a default-options run + -- records nothing and opens no span — the no-op idiom holds end to end. + mMetrics = options ^. #metrics + mTracer = options ^. #tracer + runActive :: Int -> Eff es (WorkflowOutcome a) + runActive gen = + -- EP-44: maintain the process-wide live-run count and sample the + -- @keiro.workflow.active@ gauge on both entry and exit, and open the + -- whole-run @workflow \@ span (step 'Nothing'). The body is + -- unchanged from EP-41 except for the journal-length recording below. + bracket_ + (liftIO (atomicModifyIORef' activeCountRef (\n -> (n + 1, ()))) >> sampleActive) + (liftIO (atomicModifyIORef' activeCountRef (\n -> (n - 1, ()))) >> sampleActive) + (withWorkflowSpan mTracer name wid Nothing (\_sp -> interpreted)) + where + sampleActive = liftIO (readIORef activeCountRef) >>= recordWorkflowActive mMetrics + interpreted = do + initial <- loadJournal options name wid gen + initial' <- recordPatchSetIfFresh gen initial + journalRef <- liftIO (newIORef initial') + ordinalRef <- liftIO (newIORef Map.empty) + let runHandler = interpret (handler gen journalRef ordinalRef) action + outcome <- + (Completed <$> runHandler) + `catch` (\WorkflowSuspend -> pure Suspended) + `catch` (\WorkflowCancelPending -> pure Cancelled) + `catch` (\(WorkflowRotate seedJson) -> rotateGeneration mMetrics name wid gen seedJson) + case outcome of + Completed result -> do + now <- liftIO getCurrentTime + finalMap <- liftIO (readIORef journalRef) + -- Idempotent: only appends (and so only snapshots) when the completion + -- marker is not already journaled. On a replay of an already-completed + -- workflow this is 'Nothing' and no terminal snapshot is taken (one was + -- already taken on the original completing run, if the policy fired). + mAppend <- appendCompletion name wid gen now + for_ mAppend $ \appendResult -> + when + ( shouldSnapshot + (options ^. #snapshotPolicy) + Terminal + finalMap + (appendResult ^. #streamVersion) + ) + (writeWorkflowSnapshotAdvisory mMetrics (appendResult ^. #streamId) (appendResult ^. #streamVersion) finalMap) + -- EP-44: record one @keiro.workflow.journal.length@ observation per + -- completing run (the 'Completed' path only, never 'Suspended'), + -- including a replay that completes again. Length is the recorded + -- step map plus the WorkflowCompleted marker. + recordWorkflowJournalLength mMetrics (fromIntegral (Map.size finalMap + 1)) + pure (Completed result) + Suspended -> markInstanceSuspended name wid >> pure Suspended + Cancelled -> pure Cancelled + Failed -> pure Failed + -- EP-48: the run unwound via 'WorkflowRotate'; 'rotateGeneration' + -- already journaled the seed step on the next generation and the + -- rotation marker on this one, so there is nothing more to do here. + ContinuedAsNew -> pure ContinuedAsNew + recordPatchSetIfFresh runGen initial = do + let patches = options ^. #activePatches + freshStart = Map.keysSet initial `Set.isSubsetOf` Set.singleton continueSeedStepName + if freshStart && not (Set.null patches) + then do + let encoded = Aeson.toJSON (map unPatchId (Set.toList patches)) + now <- liftIO getCurrentTime + appendJournal name wid runGen (StepRecorded patchSetStepName encoded now) >>= \case + JournalAppended{} -> pure (Map.insert patchSetStepName encoded initial) + JournalAlreadyPresent stored -> pure (Map.insert patchSetStepName stored initial) + JournalAppendConflict err -> throwIO (WorkflowJournalAppendError (Text.pack (show err))) + else pure initial + handler :: + Int -> + IORef (Map Text Aeson.Value) -> + IORef (Map Text Int) -> + EffectHandler Workflow es + handler gen journalRef ordinalRef env operation = case operation of + Step (StepName key) act -> do + journal <- liftIO (readIORef journalRef) + case Map.lookup key journal of + Just stored -> do + -- Hit: the step is already journaled, so its recorded result is + -- returned without re-running @act@ — a replay. + recordWorkflowStepReplayed mMetrics 1 + decodeStored key stored + Nothing -> do + checkCancellationPending name wid gen + a <- localSeqUnlift env (\unlift -> unlift act) + checkCancellationPending name wid gen + let encoded = Aeson.toJSON a + now <- liftIO getCurrentTime + appendOutcome <- appendJournal name wid gen (StepRecorded key encoded now) + case appendOutcome of + JournalAppended appendResult -> do + -- Miss: @act@ ran and was journaled — a fresh execution. + recordWorkflowStepExecuted mMetrics 1 + newMap <- + liftIO + ( atomicModifyIORef' journalRef $ \m -> + let m' = Map.insert key encoded m in (m', m') + ) + -- Evaluate the snapshot policy on the post-append map and version; + -- a step is never the terminal marker, hence @False@. + when + ( shouldSnapshot + (options ^. #snapshotPolicy) + NotTerminal + newMap + (appendResult ^. #streamVersion) + ) + (writeWorkflowSnapshotAdvisory mMetrics (appendResult ^. #streamId) (appendResult ^. #streamVersion) newMap) + decodeStored key encoded + JournalAlreadyPresent stored -> do + liftIO + ( atomicModifyIORef' journalRef $ \m -> + (Map.insert key stored m, ()) + ) + decodeStored key stored + JournalAppendConflict err -> + throwIO (WorkflowJournalAppendError (Text.pack (show err))) + Await (StepName key) arm -> do + journal <- liftIO (readIORef journalRef) + case Map.lookup key journal of + Just stored -> do + -- An awaitStep hit means the wake source already resolved this step; + -- the recorded result is returned without arming — a replay. An + -- awaitStep miss arms and suspends: no user @action@ ran, so it is + -- not a step execution and records nothing here. + recordWorkflowStepReplayed mMetrics 1 + decodeStored key stored + Nothing -> do + checkCancellationPending name wid gen + localSeqUnlift env (\unlift -> unlift arm) + throwIO WorkflowSuspend + CurrentWorkflow -> pure (name, wid) + CurrentRunGeneration -> pure gen + FreshOrdinal namespace -> + liftIO . atomicModifyIORef' ordinalRef $ \counters -> + let n = Map.findWithDefault 0 namespace counters + in (Map.insert namespace (n + 1) counters, n) + -- EP-48: encode the carried seed and throw the rotation sentinel, which + -- 'runWorkflowWith' catches and turns into 'rotateGeneration'. Never + -- returns to the caller within this run (result type is polymorphic). + ContinueAsNew seed -> throwIO (WorkflowRotate (Aeson.toJSON seed)) + -- EP-49: decide and journal a cross-cutting branch. Mirrors the 'Step' + -- hit/miss shape, but the miss path computes the decision from the + -- patch set recorded when this workflow generation first started. + Patch pid -> do + let key = patchStepName pid + journal <- liftIO (readIORef journalRef) + case Map.lookup key journal of + Just stored -> + -- Hit: the decision was made on an earlier run; replay it verbatim. + decodeStored key stored + Nothing -> do + checkCancellationPending name wid gen + recordedSet <- case Map.lookup patchSetStepName journal of + Nothing -> pure [] + Just stored -> decodeStored patchSetStepName stored + let decision = unPatchId pid `elem` (recordedSet :: [Text]) + encoded = Aeson.toJSON decision + now <- liftIO getCurrentTime + appendOutcome <- appendJournal name wid gen (StepRecorded key encoded now) + case appendOutcome of + JournalAppended{} -> do + liftIO + ( atomicModifyIORef' journalRef $ \m -> + (Map.insert key encoded m, ()) + ) + pure decision + JournalAlreadyPresent stored -> do + liftIO + ( atomicModifyIORef' journalRef $ \m -> + (Map.insert key stored m, ()) + ) + decodeStored key stored + JournalAppendConflict err -> + throwIO (WorkflowJournalAppendError (Text.pack (show err))) + +-- | Decode a stored journal result into the type the caller expects. +decodeStored :: (Aeson.FromJSON a) => Text -> Aeson.Value -> Eff es a +decodeStored key stored = case Aeson.fromJSON stored of + Aeson.Success a -> pure a + Aeson.Error message -> throwIO (WorkflowStepDecodeError key (Text.pack message)) + +checkCancellationPending :: (Store :> es) => WorkflowName -> WorkflowId -> Int -> Eff es () +checkCancellationPending name wid gen = do + cancelled <- stepExists name wid gen cancelledStepName + when cancelled (throwIO WorkflowCancelPending) + +{- | Pre-load a workflow's journal stream into a @step name -> result@ map. + +If a compatible snapshot exists ('loadWorkflowSnapshot'), seed the map from it +and read only the journal events /after/ the snapshot's version ("tail +replay"); the resulting map is byte-for-byte the one a full version-0 replay +would produce, because every 'StepRecorded' at or before the snapshot version +is already captured in the seed. A missing, mismatched, or undecodable +snapshot is recorded as a miss (and, for undecodable bytes, a decode failure) +before the read falls back to a full replay from version 0. +'WorkflowCompleted' contributes nothing to the map. +-} +loadJournal :: + (IOE :> es, Store :> es) => + WorkflowRunOptions -> + WorkflowName -> + WorkflowId -> + Int -> + Eff es (Map Text Aeson.Value) +loadJournal options name wid gen = do + let journalName = workflowGenerationStreamName name wid gen + snapshot <- lookupWorkflowSnapshot journalName + (seedMap, fromVersion) <- case snapshot of + Right (m, v) -> do + recordSnapshotReadHits (options ^. #metrics) 1 + pure (m, v) + Left reason -> do + recordSnapshotReadMisses (options ^. #metrics) 1 + case reason of + SnapshotDecodeFailed _ -> recordSnapshotDecodeFailures (options ^. #metrics) 1 + _ -> pure () + pure (Map.empty, StreamVersion 0) + let + events = readStreamForwardStream journalName fromVersion (options ^. #pageSize) + Streamly.fold (Fold.foldlM' accumulate (pure seedMap)) events + where + accumulate journal recorded = + case decodeRecorded workflowJournalCodec recorded of + Right (StepRecorded key value _) -> pure (Map.insert key value journal) + Right (WorkflowCompleted _) -> pure journal + Right (WorkflowCancelled _) -> pure journal + Right (WorkflowFailed _ _) -> pure journal + Right (WorkflowContinuedAsNew _ _) -> pure journal -- a rotation marker carries no step result + Left err -> throwIO (WorkflowJournalDecodeError (Text.pack (show err))) + +-- --------------------------------------------------------------------------- +-- Journal append helpers +-- --------------------------------------------------------------------------- + +data JournalAppendOutcome + = JournalAppended !AppendResult + | JournalAlreadyPresent !Aeson.Value + | JournalAppendConflict !AppendConflict + deriving stock (Eq, Show) + +prepareJournalAppend :: + (IOE :> es) => + WorkflowName -> + WorkflowId -> + Int -> + WorkflowJournalEvent -> + Eff es (Tx.Transaction JournalAppendOutcome) +prepareJournalAppend name wid gen event = do + let key = journalKey event + entryId = deterministicJournalId name wid gen key + row = journalRow name wid gen event + (status, mLastError) = instanceStatusForEvent event + journalName = workflowGenerationStreamName name wid gen + lockKey = + Text.intercalate + "/" + [unWorkflowId wid, unWorkflowName name, Text.pack (show gen), key] + base <- case encodeForAppendWithMetadata workflowJournalCodec Nothing event of + Right encoded -> pure encoded + Left err -> throwIO (WorkflowJournalEncodeError (Text.pack (show err))) + let entry = base & #eventId .~ Just entryId :: EventData + prepared <- prepareEventsIO [entry] + now <- liftIO getCurrentTime + pure $ do + lockWorkflowStepTx lockKey + lookupStepResultTx (unWorkflowId wid) (unWorkflowName name) gen key >>= \case + Just stored -> pure (JournalAlreadyPresent stored) + Nothing -> + appendToStreamTx journalName AnyVersion prepared now >>= \case + Left err -> pure (JournalAppendConflict err) + Right appendResult -> + JournalAppended appendResult + <$ recordStepTx row + <* upsertInstanceTx + (unWorkflowId wid) + (unWorkflowName name) + (fromIntegral gen) + status + mLastError + +appendJournal :: (IOE :> es, Store :> es) => WorkflowName -> WorkflowId -> Int -> WorkflowJournalEvent -> Eff es JournalAppendOutcome +appendJournal name wid gen event = + prepareJournalAppend name wid gen event >>= runTransaction + +{- | Append a journal event to a workflow's journal stream (and keep its +index row consistent), idempotently. If the entry already exists this is a +no-op returning the would-be event id. + +This is the integration helper a wake source's external-completion path uses +to record an awaited step's resolution. The append uses a deterministic event +id derived from @("keiro" : "workflow" : name : id : stepName)@ so concurrent +or retried writes collapse to one row. +-} +appendJournalEntry :: (IOE :> es, Store :> es) => WorkflowName -> WorkflowId -> WorkflowJournalEvent -> Eff es () +appendJournalEntry name wid event = void (appendJournalEntryReturningId name wid event) + +{- | Like 'appendJournalEntry' but returns the (deterministic) 'EventId' of +the entry. EP-39's fired timer needs this for @markTimerFired@. +-} +appendJournalEntryReturningId :: (IOE :> es, Store :> es) => WorkflowName -> WorkflowId -> WorkflowJournalEvent -> Eff es EventId +appendJournalEntryReturningId name wid event = do + -- EP-48: a wake source (timer fired, signalAwakeable, child completion) + -- resolves the awaited step on whichever generation the suspended run is + -- parked on — always the current (highest) one, since runs only ever operate + -- on the current generation. Resolve it here so the append and its + -- deterministic id are namespaced by that generation. + gen <- currentGeneration name wid + let key = journalKey event + entryId = deterministicJournalId name wid gen key + appendJournal name wid gen event >>= \case + JournalAppended{} -> pure entryId + JournalAlreadyPresent{} -> pure entryId + JournalAppendConflict err -> throwIO (WorkflowJournalAppendError (Text.pack (show err))) + +{- | Append a journal entry only if it is not already journaled, returning the +'AppendResult' of the fresh append (or 'Nothing' if it already existed). Used +on the completion path so a terminal ('OnTerminal') snapshot can be taken from +the completing run's 'AppendResult', while a replay of an already-completed +workflow is a no-op. +-} +appendCompletion :: (IOE :> es, Store :> es) => WorkflowName -> WorkflowId -> Int -> UTCTime -> Eff es (Maybe AppendResult) +appendCompletion name wid gen now = do + appendJournal name wid gen (WorkflowCompleted now) >>= \case + JournalAppended appendResult -> pure (Just appendResult) + JournalAlreadyPresent{} -> pure Nothing + JournalAppendConflict err -> throwIO (WorkflowJournalAppendError (Text.pack (show err))) + +{- | Perform a continue-as-new rotation (EP-48): close generation @gen@ and open +generation @gen + 1@, seeded with @seedJson@. Returns 'ContinuedAsNew'. + +The two appends are ordered for crash-safety. We append the next generation's +seed step __first__ (a single @StepRecorded continueSeedStepName seedJson@), +which advances @MAX(generation)@ — and therefore 'currentGeneration' — to +@gen + 1@. After that commits, any re-run resolves the current generation to +@gen + 1@, hydrates from the seed, and never re-enters generation @gen@; so even +a crash between the two appends converges to "continue from the seed", never +re-running generation @gen@'s work. We then append the terminal +'WorkflowContinuedAsNew' marker on generation @gen@. Both appends are guarded by +an existence check and use deterministic, generation-namespaced ids, so the +whole rotation is idempotent. + +The seed step alone carries the state forward (the next run's 'loadJournal' +reads it and 'restoreSeed' hits it); we additionally snapshot the one-entry seed +map at the seed step's version so the next generation hydrates in O(1) rather +than re-reading even that one event. The snapshot is advisory (a miss only costs +a single event read), so it is written unconditionally on rotation regardless of +the run's 'snapshotPolicy' — rotation is exactly when a fresh snapshot earns its +keep. +-} +rotateGeneration :: + forall a es. + (IOE :> es, Store :> es, Error StoreError :> es) => + Maybe KeiroMetrics -> + WorkflowName -> + WorkflowId -> + Int -> + Aeson.Value -> + Eff es (WorkflowOutcome a) +rotateGeneration mMetrics name wid gen seedJson = do + let nextGen = gen + 1 + now <- liftIO getCurrentTime + -- 1. Seed step on the NEXT generation first (advances the current generation). + appendJournal name wid nextGen (StepRecorded continueSeedStepName seedJson now) >>= \case + JournalAppended appendResult -> + writeWorkflowSnapshotAdvisory + mMetrics + (appendResult ^. #streamId) + (appendResult ^. #streamVersion) + (Map.singleton continueSeedStepName seedJson) + JournalAlreadyPresent{} -> pure () + JournalAppendConflict err -> throwIO (WorkflowJournalAppendError (Text.pack (show err))) + -- 2. Terminal rotation marker on the CURRENT generation (audit + closes it). + appendJournal name wid gen (WorkflowContinuedAsNew nextGen now) >>= \case + JournalAppended{} -> pure () + JournalAlreadyPresent{} -> pure () + JournalAppendConflict err -> throwIO (WorkflowJournalAppendError (Text.pack (show err))) + pure ContinuedAsNew + +{- | Snapshot a workflow state after its journal append has committed. The +snapshot is advisory: a store failure is counted and cannot turn the +already-durable workflow transition into a failed run. +-} +writeWorkflowSnapshotAdvisory :: + (IOE :> es, Store :> es, Error StoreError :> es) => + Maybe KeiroMetrics -> + StreamId -> + StreamVersion -> + WorkflowState -> + Eff es () +writeWorkflowSnapshotAdvisory mMetrics streamId version state = do + -- WorkflowState is already a Map Text Value assembled from journaled step + -- results, so this path has no aggregate RegFile/uninit encode to guard. + outcome <- tryError @StoreError (writeWorkflowSnapshot streamId version state) + case outcome of + Right () -> pure () + Left _ -> recordSnapshotWriteFailures mMetrics 1 + +instanceStatusForEvent :: WorkflowJournalEvent -> (WorkflowStatus, Maybe Text) +instanceStatusForEvent = \case + StepRecorded{} -> (WfRunning, Nothing) + WorkflowCompleted{} -> (WfCompleted, Nothing) + WorkflowCancelled{} -> (WfCancelled, Nothing) + WorkflowFailed reason _ -> (WfFailed, Just reason) + WorkflowContinuedAsNew{} -> (WfRunning, Nothing) + +-- | The reserved step-name key a journal event indexes under. +journalKey :: WorkflowJournalEvent -> Text +journalKey = \case + StepRecorded{stepName = key} -> key + WorkflowCompleted{} -> completedStepName + WorkflowCancelled{} -> cancelledStepName + WorkflowFailed{} -> failedStepName + WorkflowContinuedAsNew{} -> continuedAsNewStepName + +-- | The index row corresponding to a journal event, on the given generation. +journalRow :: WorkflowName -> WorkflowId -> Int -> WorkflowJournalEvent -> WorkflowStepRow +journalRow name wid gen = \case + StepRecorded key value t -> + WorkflowStepRow + { workflowId = unWorkflowId wid + , workflowName = unWorkflowName name + , generation = gen + , stepName = key + , result = value + , recordedAt = t + } + WorkflowCompleted t -> + WorkflowStepRow + { workflowId = unWorkflowId wid + , workflowName = unWorkflowName name + , generation = gen + , stepName = completedStepName + , result = Aeson.Null + , recordedAt = t + } + WorkflowCancelled t -> + WorkflowStepRow + { workflowId = unWorkflowId wid + , workflowName = unWorkflowName name + , generation = gen + , stepName = cancelledStepName + , result = Aeson.Null + , recordedAt = t + } + WorkflowFailed r t -> + WorkflowStepRow + { workflowId = unWorkflowId wid + , workflowName = unWorkflowName name + , generation = gen + , stepName = failedStepName + , result = Aeson.toJSON r + , recordedAt = t + } + WorkflowContinuedAsNew g t -> + WorkflowStepRow + { workflowId = unWorkflowId wid + , workflowName = unWorkflowName name + , generation = gen + , stepName = continuedAsNewStepName + , result = Aeson.toJSON g -- the NEXT generation this rotation opens + , recordedAt = t + } + +{- | A stable, collision-resistant journal-event id from +@("keiro" : "workflow" : name : id : generation : stepName)@ via a v5 UUID. +Mirrors 'Keiro.ProcessManager.deterministicCommandId': the same inputs always +yield the same id, so a re-append of the same step collapses to the same row. + +The /generation/ (EP-48) is part of the id so a step named @"s1"@ in +generation 0 and the same name in generation 1 produce __different__ kiroku +event ids — they live on different physical streams, but the event id is +global, so namespacing it by generation keeps rotated generations from +colliding on the deterministic id. +-} +deterministicJournalId :: WorkflowName -> WorkflowId -> Int -> Text -> EventId +deterministicJournalId (WorkflowName name) (WorkflowId wid) gen key = + EventId $ + UUID.V5.generateNamed UUID.V5.namespaceURL $ + fmap (fromIntegral . fromEnum) $ + Text.unpack $ + Text.intercalate ":" ["keiro", "workflow", name, wid, Text.pack (show gen), key] diff --git a/src/Keiro/Workflow/Awakeable.hs b/src/Keiro/Workflow/Awakeable.hs new file mode 100644 --- /dev/null +++ b/src/Keiro/Workflow/Awakeable.hs @@ -0,0 +1,340 @@ +{- | Awakeables: durable promises an external system resolves. + +== What this gives you + +A workflow allocates an opaque 'AwakeableId', hands it to some external system +(a webhook handler, a human approver, an LLM tool call), and suspends until +that system /signals/ the id with a result — no polling, no bespoke +"wait for event X then react in a process manager" wiring. + +@ +approvalFlow :: ('Workflow' ':>' es, 'Store' ':>' es, 'IOE' ':>' es) => Eff es Text +approvalFlow = do + (aid, await) <- 'awakeableNamed' (StepName \"approval\") -- allocate the promise + -- (hand @aid@ to a webhook handler / human / LLM tool here) + decision <- await -- SUSPEND until signalled + 'Keiro.Workflow.step' (StepName \"use\") (pure (decision <> \"!\")) +@ + +On the __first__ 'Keiro.Workflow.runWorkflow' this returns 'Suspended' (the run +parked on @await@) and a @pending@ row appears in @keiro_awakeables@. An +external caller later runs @'signalAwakeable' aid \"ok\"@, which flips the row +to @completed@ /and/ appends a @StepRecorded \"awk:\\"@ 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:\@ before awaiting @awk:\@. + Replay reads the journaled id, so a resumed workflow allocates the same id it + already handed out without making that id guessable from public coordinates. +* 'awakeableNamed' (caller-supplied label) is the __stable primitive__; + 'awakeable' is an ordinal convenience whose label is positional (a fragile + derivation across code edits — see its Haddock). +* Awakeables journal their completion as ordinary 'StepRecorded' events under + the reserved @awk:@ prefix ('Keiro.Workflow.awakeableStepPrefix'), never a + new event type, so EP-38's replay loop stays uniform. +* 'signalAwakeable' is idempotent /and/ crash-safe: it commits the row update + and journal append in one transaction for new signals, a double signal + returns 'False' and does not change the recorded value, and a signal of an + already-@completed@ awakeable re-appends the journal entry from the stored + payload to repair historical wedges. +* 'cancelAwakeable' abandons a still-@pending@ promise; a workflow that + re-enters its @await@ then throws 'WorkflowAwakeableCancelled', which the + author can @catch@ for compensation. If uncaught, EP-42's resume worker + records an attempt, backs off, and eventually appends 'WorkflowFailed' at the + configured failure ceiling. +* @countPendingAwakeables@ (in "Keiro.Workflow.Awakeable.Schema") backs EP-44's + @keiro.workflow.awakeables.pending@ gauge. +-} +module Keiro.Workflow.Awakeable ( + -- * Awakeable ids + AwakeableId (..), + awakeableIdToUuid, + awakeableIdText, + deterministicAwakeableId, + + -- * Authoring surface (inside a workflow) + awakeableNamed, + awakeable, + + -- * External completion (outside a workflow) + signalAwakeable, + cancelAwakeable, + + -- * Errors + WorkflowAwakeableCancelled (..), +) +where + +import Control.Exception (Exception) +import Data.Text qualified as Text +import Data.UUID (UUID) +import Data.UUID qualified as UUID +import Data.UUID.V4 qualified as UUID.V4 +import Data.UUID.V5 qualified as UUID.V5 +import Effectful (Eff, IOE, (:>)) +import Effectful.Exception (throwIO) +import Keiro.Prelude +import Keiro.Workflow ( + JournalAppendOutcome (..), + StepName (..), + Workflow, + WorkflowError (..), + WorkflowId (..), + WorkflowJournalEvent (..), + WorkflowName (..), + appendJournalEntry, + awaitStep, + awakeableAllocStepPrefix, + awakeableStepPrefix, + currentGeneration, + currentRunGeneration, + currentWorkflow, + freshOrdinal, + prepareJournalAppend, + step, + ) +import Keiro.Workflow.Awakeable.Schema ( + AwakeableStatus (..), + cancelAwakeableTx, + completeAwakeableTx, + lookupAwakeable, + registerAwakeableTx, + ) +import Kiroku.Store.Effect (Store) +import Kiroku.Store.Transaction (runTransaction) +import "hasql-transaction" Hasql.Transaction qualified as Tx + +-- --------------------------------------------------------------------------- +-- Awakeable ids +-- --------------------------------------------------------------------------- + +{- | The opaque id of an awakeable. New allocations are random and journaled by +'awakeableNamed'; 'deterministicAwakeableId' is retained only as a legacy +generation-0 adoption helper. The @ToJSON@\/@FromJSON@ instances are over the +inner UUID, so the workflow journal can replay the id and webhook payloads may +carry it. +-} +newtype AwakeableId = AwakeableId UUID + deriving stock (Eq, Show, Generic) + deriving newtype (ToJSON, FromJSON) + +-- | The raw UUID inside an 'AwakeableId'. +awakeableIdToUuid :: AwakeableId -> UUID +awakeableIdToUuid (AwakeableId u) = u + +{- | The 'AwakeableId' rendered as text — the suffix of the @awk:\@ +journal step name an awakeable's completion is recorded under. +-} +awakeableIdText :: AwakeableId -> Text +awakeableIdText = UUID.toText . awakeableIdToUuid + +{- | The legacy deterministic 'AwakeableId' for a @(workflow name, workflow id, +label)@: a v5 UUID over @(\"keiro\":\"awakeable\":name:id:label)@. + +This is predictable from public coordinates, so new code must not hand-derive +ids with it. It remains exported for operators and for generation-0 adoption: +if a pre-change workflow already registered a row under this id, the first +post-change allocation adopts that row so the in-flight promise keeps working. +-} +deterministicAwakeableId :: WorkflowName -> WorkflowId -> Text -> AwakeableId +deterministicAwakeableId (WorkflowName name) (WorkflowId wid) label = + AwakeableId $ + UUID.V5.generateNamed UUID.V5.namespaceURL $ + fmap (fromIntegral . fromEnum) $ + Text.unpack $ + Text.intercalate ":" ["keiro", "awakeable", name, wid, label] + +-- --------------------------------------------------------------------------- +-- Errors +-- --------------------------------------------------------------------------- + +{- | Thrown out of 'Keiro.Workflow.runWorkflow' when a workflow re-enters the +@await@ of an awakeable that was 'cancelAwakeable'd. A cancelled awakeable will +never be signalled, so suspending forever would be wrong and silently +completing would fabricate a result; the workflow author can @catch@ this to +run compensation. If uncaught, the resume worker records the attempt and +eventually marks the workflow failed at its configured ceiling. +-} +newtype WorkflowAwakeableCancelled = WorkflowAwakeableCancelled AwakeableId + deriving stock (Eq, Show) + +instance Exception WorkflowAwakeableCancelled + +-- --------------------------------------------------------------------------- +-- Authoring surface +-- --------------------------------------------------------------------------- + +{- | Allocate an awakeable under the stable, caller-supplied @label@. Returns +the 'AwakeableId' (hand it to the external system) and an @await@ action that +'Suspended's the workflow until the awakeable is signalled, then yields the +decoded payload on a later run. + +The @label@ is the only fully-deterministic option: it survives code edits that +insert or remove awakeables elsewhere in the workflow (the same robustness +argument EP-38 makes for named steps over positional history). Prefer this over +'awakeable' for anything that may outlive a code change mid-flight. +-} +awakeableNamed :: + (Workflow :> es, Store :> es, IOE :> es, FromJSON a) => + StepName -> + Eff es (AwakeableId, Eff es a) +awakeableNamed (StepName label) = do + (name, wid) <- currentWorkflow + gen <- currentRunGeneration + aid <- + step (StepName (awakeableAllocStepPrefix <> label)) $ + allocateAwakeableId name wid gen label + let + stepNm = StepName (awakeableStepPrefix <> awakeableIdText aid) + await = awaitCancellable name wid aid stepNm + pure (aid, await) + +allocateAwakeableId :: + (Store :> es, IOE :> es) => + WorkflowName -> + WorkflowId -> + Int -> + Text -> + Eff es AwakeableId +allocateAwakeableId name wid gen label + | gen <= 0 = do + let legacy = deterministicAwakeableId name wid label + existing <- lookupAwakeable (awakeableIdToUuid legacy) + case existing of + Just _ -> pure legacy + Nothing -> AwakeableId <$> liftIO UUID.V4.nextRandom + | otherwise = AwakeableId <$> liftIO UUID.V4.nextRandom + +{- | Allocate an awakeable under an ordinal label (the @N@th awakeable in a run +becomes @ord:N@). Convenient, but its determinism is __conditional__: adding or +removing an 'awakeable' call earlier in the workflow shifts every later ordinal +and so changes their derived ids, which corrupts an in-flight workflow exactly +the way EP-38 warns positional history does. Prefer 'awakeableNamed' for +anything that may outlive a code edit. +-} +awakeable :: + (Workflow :> es, Store :> es, IOE :> es, FromJSON a) => + Eff es (AwakeableId, Eff es a) +awakeable = do + n <- freshOrdinal awakeableStepPrefix + awakeableNamed (StepName ("ord:" <> Text.pack (show n))) + +{- | EP-38's 'awaitStep', wrapped so that a re-entered @await@ on a +'Cancelled' awakeable throws 'WorkflowAwakeableCancelled' instead of suspending +forever. The check lives /inside/ the arming action because 'awaitStep' runs +@arm@ only on the miss path (the awakeable not yet journaled) and re-runs it on +every resume until it resolves: on a miss we either notice the cancel and throw, +or (re-)register the idempotent @pending@ row and suspend. On the hit path +('signalAwakeable' already journaled the result) @arm@ is never run, so a +signalled-then-cancelled race still returns the signalled value (signal wins — a +resolved promise cannot be un-resolved). +-} +awaitCancellable :: + (Workflow :> es, Store :> es, IOE :> es, FromJSON a) => + WorkflowName -> WorkflowId -> AwakeableId -> StepName -> Eff es a +awaitCancellable name wid aid stepNm = + awaitStep stepNm $ do + existing <- lookupAwakeable (awakeableIdToUuid aid) + case existing of + Just row + | row ^. #status == Cancelled -> + throwIO (WorkflowAwakeableCancelled aid) + | row ^. #status == Completed + , Just payload <- row ^. #payload -> do + now <- liftIO getCurrentTime + appendJournalEntry + name + wid + StepRecorded + { stepName = unStepName stepNm + , result = payload + , recordedAt = now + } + _ -> + runTransaction $ + registerAwakeableTx (awakeableIdToUuid aid) (unWorkflowName name) (unWorkflowId wid) + +-- --------------------------------------------------------------------------- +-- External completion +-- --------------------------------------------------------------------------- + +{- | Resolve an awakeable from outside the workflow: store @result@ in the +@keiro_awakeables@ row /and/ append a @StepRecorded@ to the owning workflow's +journal so the next run replays past the @await@. + +Idempotent and crash-safe: + +* Returns 'True' only when /this/ call transitioned the row @pending@ -> + @completed@; a second signal (or a signal of a @cancelled@ row) returns + 'False' and leaves the stored payload unchanged. +* For a @pending@ row, the row transition and journal append happen in one + transaction. For an already-@completed@ row, the journal entry is re-appended + from the stored payload to repair rows wedged before that atomic path existed. + The append path is idempotent (deterministic event id plus step-index check), + so a re-append collapses to a no-op once the entry is present. + +A 'False' return therefore does not mean "nothing happened": the journal may +still have been repaired. Returns 'False' for an unknown id. +-} +signalAwakeable :: (IOE :> es, Store :> es, ToJSON r) => AwakeableId -> r -> Eff es Bool +signalAwakeable aid result = do + mrow <- lookupAwakeable (awakeableIdToUuid aid) + case mrow of + Nothing -> pure False + Just row + | row ^. #status == Cancelled -> pure False + | otherwise -> do + now <- liftIO getCurrentTime + let payload = + if row ^. #status == Completed + then row ^. #payload + else Just (toJSON result) + case payload of + Nothing -> pure False + Just payloadValue -> do + let ownerName = WorkflowName (row ^. #ownerWorkflowName) + ownerId = WorkflowId (row ^. #ownerWorkflowId) + gen <- currentGeneration ownerName ownerId + appendTx <- + prepareJournalAppend + ownerName + ownerId + gen + StepRecorded + { stepName = awakeableStepPrefix <> awakeableIdText aid + , result = payloadValue + , recordedAt = now + } + (transitioned, appendOutcome) <- + runTransaction $ do + transitioned <- + if row ^. #status == Pending + then completeAwakeableTx (awakeableIdToUuid aid) (toJSON result) now + else pure False + appendOutcome <- appendTx + condemnOnAppendConflict appendOutcome + pure (transitioned, appendOutcome) + throwOnAppendConflict appendOutcome + pure transitioned + +condemnOnAppendConflict :: JournalAppendOutcome -> Tx.Transaction () +condemnOnAppendConflict = \case + JournalAppendConflict{} -> Tx.condemn + _ -> pure () + +throwOnAppendConflict :: JournalAppendOutcome -> Eff es () +throwOnAppendConflict = \case + JournalAppendConflict err -> throwIO (WorkflowJournalAppendError (Text.pack (show err))) + _ -> pure () + +{- | Abandon a still-@pending@ awakeable: flips its row to @cancelled@ and +writes __no__ journal entry (there is no result value to record). Returns 'True' +when it transitioned a @pending@ row, 'False' otherwise (already completed, +already cancelled, or unknown). A workflow that later re-enters the awakeable's +@await@ then throws 'WorkflowAwakeableCancelled'. +-} +cancelAwakeable :: (Store :> es) => AwakeableId -> Eff es Bool +cancelAwakeable aid = + runTransaction $ cancelAwakeableTx (awakeableIdToUuid aid) diff --git a/src/Keiro/Workflow/Awakeable/Schema.hs b/src/Keiro/Workflow/Awakeable/Schema.hs new file mode 100644 --- /dev/null +++ b/src/Keiro/Workflow/Awakeable/Schema.hs @@ -0,0 +1,214 @@ +{- | The @keiro_awakeables@ table: durable storage for awakeables (external +promises a workflow suspends on). + +Mirrors the @Keiro.Timer@ \/ @Keiro.Timer.Schema@ split: this module owns the +row type, the 'AwakeableStatus' lifecycle, and the hasql statements; +"Keiro.Workflow.Awakeable" owns the effectful authoring\/completion surface. + +* 'registerAwakeableTx' inserts a @pending@ row idempotently (the + @ON CONFLICT DO NOTHING@ EP-38's @awaitStep@ arming contract requires). +* 'lookupAwakeable' reads a row back. +* 'completeAwakeableTx' transitions a @pending@ row to @completed@ (guarded so + a double signal is a no-op), and 'cancelAwakeableTx' transitions it to + @cancelled@. +* 'countPendingAwakeables' counts outstanding promises — the seam EP-44 reads + for its @keiro.workflow.awakeables.pending@ gauge. + +Callers normally use the re-exports / surface from "Keiro.Workflow.Awakeable" +rather than this module directly; EP-44 imports 'countPendingAwakeables' here +without pulling in the effect surface. +-} +module Keiro.Workflow.Awakeable.Schema ( + -- * Rows and status + AwakeableStatus (..), + AwakeableRow (..), + statusToText, + statusFromText, + + -- * Storage (run inside the caller's transaction) + registerAwakeableTx, + completeAwakeableTx, + cancelAwakeableTx, + + -- * Read-only lookups + lookupAwakeable, + countPendingAwakeables, +) +where + +import Contravariant.Extras (contrazip3) +import Data.UUID (UUID) +import Effectful (Eff, (:>)) +import Hasql.Decoders qualified as D +import Hasql.Encoders qualified as E +import Hasql.Statement (Statement, preparable) +import Keiro.Prelude +import Kiroku.Store.Effect (Store) +import Kiroku.Store.Transaction (runTransaction) +import "hasql-transaction" Hasql.Transaction qualified as Tx + +{- | An awakeable's lifecycle state. + +* 'Pending' — allocated and waiting for an external signal; the workflow is + suspended on it. +* 'Completed' — signalled with a payload; terminal. +* 'Cancelled' — abandoned before it was signalled; terminal; also the decode + fallback for an unrecognized stored value (the same defensive choice + "Keiro.Timer.Schema" makes). +-} +data AwakeableStatus + = Pending + | Completed + | Cancelled + deriving stock (Generic, Eq, Show) + +{- | An awakeable row as stored: the deterministic id, the owning workflow's +name and instance id, the live 'status', the signalled 'payload' (JSON, set +only once 'Completed'), and the timestamps. +-} +data AwakeableRow = AwakeableRow + { awakeableId :: !UUID + , ownerWorkflowName :: !Text + , ownerWorkflowId :: !Text + , status :: !AwakeableStatus + , payload :: !(Maybe Value) + , createdAt :: !UTCTime + , updatedAt :: !UTCTime + , completedAt :: !(Maybe UTCTime) + } + deriving stock (Generic, Eq, Show) + +{- | Insert a @pending@ awakeable row inside the caller's transaction. +Idempotent by @ON CONFLICT (awakeable_id) DO NOTHING@ — exactly what EP-38's +"arm must be idempotent" contract needs, since a resumed workflow re-runs the +arming action on every resume until the awakeable resolves. +-} +registerAwakeableTx :: UUID -> Text -> Text -> Tx.Transaction () +registerAwakeableTx aid name wid = + Tx.statement (aid, name, wid) registerAwakeableStmt + +{- | Transition a @pending@ awakeable to @completed@, storing @payload@ and the +completion time, inside the caller's transaction. The @status = 'pending'@ +guard makes a double-signal a no-op; returns 'True' only when this call +performed the transition (so the caller knows whether it was the one that +resolved the promise). +-} +completeAwakeableTx :: UUID -> Value -> UTCTime -> Tx.Transaction Bool +completeAwakeableTx aid result now = + Tx.statement (aid, result, now) completeAwakeableStmt + +{- | Transition a @pending@ awakeable to @cancelled@ inside the caller's +transaction. Only @pending@ rows match, so an already-completed (or +already-cancelled) awakeable is left untouched and the call returns 'False'. +-} +cancelAwakeableTx :: UUID -> Tx.Transaction Bool +cancelAwakeableTx aid = + Tx.statement aid cancelAwakeableStmt + +-- | Read an awakeable row by id. 'Nothing' if no such awakeable exists. +lookupAwakeable :: (Store :> es) => UUID -> Eff es (Maybe AwakeableRow) +lookupAwakeable aid = + runTransaction (Tx.statement aid lookupAwakeableStmt) + +{- | Count awakeables currently @pending@. Read-only. EP-44 backs the +@keiro.workflow.awakeables.pending@ gauge with this. +-} +countPendingAwakeables :: (Store :> es) => Eff es Int +countPendingAwakeables = + runTransaction (Tx.statement () countPendingAwakeablesStmt) + +registerAwakeableStmt :: Statement (UUID, Text, Text) () +registerAwakeableStmt = + preparable + """ + INSERT INTO keiro.keiro_awakeables + (awakeable_id, owner_workflow_name, owner_workflow_id, status) + VALUES ($1, $2, $3, 'pending') + ON CONFLICT (awakeable_id) DO NOTHING + """ + ( contrazip3 + (E.param (E.nonNullable E.uuid)) + (E.param (E.nonNullable E.text)) + (E.param (E.nonNullable E.text)) + ) + D.noResult + +completeAwakeableStmt :: Statement (UUID, Value, UTCTime) Bool +completeAwakeableStmt = + preparable + """ + UPDATE keiro.keiro_awakeables + SET status = 'completed', + payload = $2, + completed_at = $3, + updated_at = now() + WHERE awakeable_id = $1 + AND status = 'pending' + """ + ( contrazip3 + (E.param (E.nonNullable E.uuid)) + (E.param (E.nonNullable E.jsonb)) + (E.param (E.nonNullable E.timestamptz)) + ) + ((> 0) <$> D.rowsAffected) + +cancelAwakeableStmt :: Statement UUID Bool +cancelAwakeableStmt = + preparable + """ + UPDATE keiro.keiro_awakeables + SET status = 'cancelled', + updated_at = now() + WHERE awakeable_id = $1 + AND status = 'pending' + """ + (E.param (E.nonNullable E.uuid)) + ((> 0) <$> D.rowsAffected) + +lookupAwakeableStmt :: Statement UUID (Maybe AwakeableRow) +lookupAwakeableStmt = + preparable + """ + SELECT awakeable_id, owner_workflow_name, owner_workflow_id, status, + payload, created_at, updated_at, completed_at + FROM keiro.keiro_awakeables + WHERE awakeable_id = $1 + """ + (E.param (E.nonNullable E.uuid)) + (D.rowMaybe awakeableRowDecoder) + +countPendingAwakeablesStmt :: Statement () Int +countPendingAwakeablesStmt = + preparable + """ + SELECT count(*) + FROM keiro.keiro_awakeables + WHERE status = 'pending' + """ + E.noParams + (D.singleRow (fromIntegral <$> D.column (D.nonNullable D.int8))) + +awakeableRowDecoder :: D.Row AwakeableRow +awakeableRowDecoder = + AwakeableRow + <$> D.column (D.nonNullable D.uuid) + <*> D.column (D.nonNullable D.text) + <*> D.column (D.nonNullable D.text) + <*> (statusFromText <$> D.column (D.nonNullable D.text)) + <*> D.column (D.nullable D.jsonb) + <*> D.column (D.nonNullable D.timestamptz) + <*> D.column (D.nonNullable D.timestamptz) + <*> D.column (D.nullable D.timestamptz) + +statusToText :: AwakeableStatus -> Text +statusToText = \case + Pending -> "pending" + Completed -> "completed" + Cancelled -> "cancelled" + +statusFromText :: Text -> AwakeableStatus +statusFromText = \case + "pending" -> Pending + "completed" -> Completed + "cancelled" -> Cancelled + _ -> Cancelled diff --git a/src/Keiro/Workflow/Child.hs b/src/Keiro/Workflow/Child.hs new file mode 100644 --- /dev/null +++ b/src/Keiro/Workflow/Child.hs @@ -0,0 +1,462 @@ +{- | Child workflows: spawn, wait on, and cancel a workflow from inside another. + +== What this gives you + +Fan-out\/fan-in composition of durable workflows. A /parent/ workflow spawns a +/child/ (a second workflow with its own journal stream), waits for the child's +result, and may cancel a child it no longer needs — with the whole relationship +surviving a crash, because the spawn is recorded in the parent's journal and the +link is stored in @keiro_workflow_children@. + +@ +parent :: ('Workflow' ':>' es, 'Store' ':>' es, 'IOE' ':>' es) => Eff es Text +parent = do + h <- 'spawnChild' (WorkflowName \"ship-order\") (WorkflowId \"ord-7\") shipWorkflow + result <- 'awaitChild' h -- SUSPEND until the child completes + _ <- 'Keiro.Workflow.step' (StepName \"notify\") (pure (\"shipped: \" <> result)) + pure result +@ + +== How it works (contract recap for downstream plans) + +* __'spawnChild' is a journaled step.__ It records a @StepRecorded + \"child:\\"@ 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:\: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:\:result\") arm@. On the miss path it + re-delivers a completed child's stored result onto the current parent + generation (attach semantics), throws 'WorkflowChildCancelled' if the child + was cancelled meanwhile, and otherwise re-asserts nothing new (the spawn + already registered the link). On the hit path + it decodes a tagged parent-journal envelope: @{"ok": result}@ returns the + child result, @{"cancelled": true}@ throws 'WorkflowChildCancelled', + @{"failed": reason}@ throws 'WorkflowChildFailed', and legacy raw values are + still decoded as pre-envelope successful results. +* __'runChildWorkflow'__ is what the resume worker selects (instead of bare + 'Keiro.Workflow.runWorkflowWith') for any workflow that is some parent's child: + on 'Completed' it runs 'childCompletionHook', which flips the child row to + @completed@ and appends @{"ok": result}@ to the parent's + @child:\:result@ step. If it finds a historically + @cancelled@-but-unmarked row, it ensures the child cancellation marker and + parent sentinel before returning 'Cancelled'. +* __'cancelChild'__ flips the child row to @cancelled@ and, in the same + transaction, writes a 'Keiro.Workflow.WorkflowCancelled' marker to the + /child/ journal plus a @{"cancelled": true}@ sentinel as the parent's + await-step result. Retrying after a historical row-only cancel repairs both + markers even though the return value remains 'False' ("this call did not + transition the row"). +* @'Keiro.Workflow.Child.Schema.countActiveChildren'@ backs a potential + @keiro.workflow.children.active@ gauge for EP-44. +-} +module Keiro.Workflow.Child ( + -- * Child handles and reserved step names + ChildHandle (..), + childSpawnStepName, + childResultStepName, + + -- * Authoring surface (inside a parent workflow) + spawnChild, + awaitChild, + + -- * External control + cancelChild, + + -- * Driving a child to completion (used by the resume worker) + runChildWorkflow, + childCompletionHook, + + -- * Errors + WorkflowChildCancelled (..), + WorkflowChildFailed (..), +) +where + +import Control.Exception (Exception) +import Data.Aeson qualified as Aeson +import Data.Aeson.KeyMap qualified as KeyMap +import Data.Text qualified as Text +import Effectful (Eff, IOE, (:>)) +import Effectful.Error.Static (Error) +import Effectful.Exception (throwIO) +import Keiro.Prelude +import Keiro.Workflow ( + JournalAppendOutcome (..), + StepName (..), + Workflow, + WorkflowError (..), + WorkflowId (..), + WorkflowJournalEvent (..), + WorkflowName (..), + WorkflowOutcome (..), + WorkflowRunOptions, + appendJournalEntry, + awaitStep, + childStepPrefix, + currentGeneration, + currentWorkflow, + prepareJournalAppend, + runWorkflowWith, + step, + ) +import Keiro.Workflow.Child.Schema ( + ChildRow, + ChildStatus (..), + lookupChild, + markChildCancelledTx, + markChildResultTx, + registerChildTx, + ) +import Keiro.Workflow.Instance (WorkflowStatus (..), upsertInstanceTx) +import Kiroku.Store.Effect (Store) +import Kiroku.Store.Error (StoreError) +import Kiroku.Store.Transaction (runTransaction) +import "hasql-transaction" Hasql.Transaction qualified as Tx + +-- --------------------------------------------------------------------------- +-- Handles and reserved step names +-- --------------------------------------------------------------------------- + +{- | An in-memory handle to a spawned child, returned by 'spawnChild' and taken +by 'awaitChild' \/ 'cancelChild'. The phantom type parameter @a@ records the +child's result type so 'awaitChild' decodes without an extra annotation; the +handle itself carries only the child's name and id (the child journal is +@wf:\-\@). +-} +data ChildHandle a = ChildHandle + { childName :: !WorkflowName + , childWfId :: !WorkflowId + } + deriving stock (Eq, Show) + +{- | The reserved /spawn/ step name a child is recorded under in its parent's +journal: @child:\@ (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:\:result@. +-} +childResultStepName :: WorkflowId -> Text +childResultStepName (WorkflowId wid) = childStepPrefix <> wid <> ":result" + +-- --------------------------------------------------------------------------- +-- Errors +-- --------------------------------------------------------------------------- + +{- | Thrown out of 'awaitChild' when the awaited child was 'cancelChild'led. A +cancelled child never produces a result, so suspending forever would be wrong +and fabricating a result would be wrong; the parent author can @catch@ this to +run compensation. If uncaught, the resume worker records the parent attempt, +backs it off, and eventually marks the parent failed at its configured ceiling. +Mirrors EP-40's 'Keiro.Workflow.Awakeable.WorkflowAwakeableCancelled'. +-} +data WorkflowChildCancelled = WorkflowChildCancelled WorkflowName WorkflowId + deriving stock (Eq, Show) + +instance Exception WorkflowChildCancelled + +{- | Thrown out of 'awaitChild' when the child was terminally failed by the +resume worker. Carries the child's identity plus the persisted failure reason. +-} +data WorkflowChildFailed = WorkflowChildFailed WorkflowName WorkflowId Text + deriving stock (Eq, Show) + +instance Exception WorkflowChildFailed + +-- --------------------------------------------------------------------------- +-- Authoring surface +-- --------------------------------------------------------------------------- + +{- | Spawn a child workflow. Records a @StepRecorded \"child:\\"@ in +the /parent/ journal (so a replay short-circuits and never re-spawns) and +inserts an idempotent @running@ link row, then returns a 'ChildHandle'. The +child is driven to completion by the resume worker from the registry, so +@childNm@ __must be registered there__; @childDef@ is accepted for authoring +ergonomics but is not run here. + +A child id names one execution globally. Spawning an id whose child row already +completed attaches to that execution: 'awaitChild' re-delivers the stored +result onto the parent's current generation. To run a fresh child after +'Keiro.Workflow.continueAsNew', derive a fresh child id from the carried seed. +-} +spawnChild :: + (Workflow :> es, Store :> es) => + -- | The child's name (must be in the resume worker's registry). + WorkflowName -> + -- | The child's id (names the child journal). + WorkflowId -> + -- | The child workflow definition (for authoring; the registry actually runs it). + Eff (Workflow : es) a -> + Eff es (ChildHandle a) +spawnChild childNm childWid _childDef = do + (parentNm, parentWid) <- currentWorkflow + let spawnStep = StepName (childSpawnStepName childWid) + resultStep = childResultStepName childWid + -- Journaled as a step in the PARENT journal: a parent replay short-circuits + -- this body, and the ON CONFLICT DO NOTHING register collapses on re-run. + _ <- + step spawnStep $ do + runTransaction $ + registerChildTx + (unWorkflowId childWid) + (unWorkflowName childNm) + (unWorkflowId parentWid) + (unWorkflowName parentNm) + resultStep + *> upsertInstanceTx + (unWorkflowId childWid) + (unWorkflowName childNm) + 0 + WfRunning + Nothing + pure () + pure (ChildHandle childNm childWid) + +{- | Suspend the parent until the child completes, then return the child's +result. This is EP-38's 'awaitStep' on the @child:\:result@ step: +'childCompletionHook' journals that step into the parent when the child +finishes, so the next parent run replays past the wait and decodes the result. + +If the child was cancelled or failed, throws 'WorkflowChildCancelled' or +'WorkflowChildFailed'. Parent-journal values are tagged envelopes +(@{"ok": ...}@, @{"cancelled": true}@, @{"failed": reason}@) with a legacy raw +success fallback; a decode mismatch throws 'WorkflowStepDecodeError'. +-} +awaitChild :: + (Workflow :> es, Store :> es, IOE :> es, FromJSON a) => + ChildHandle a -> + Eff es a +awaitChild (ChildHandle childNm childWid) = do + let resultStep = StepName (childResultStepName childWid) + arm = do + mrow <- lookupChild (unWorkflowId childWid) (unWorkflowName childNm) + case mrow of + Just row + | (row ^. #status) == ChildCancelled -> + throwIO (WorkflowChildCancelled childNm childWid) + | (row ^. #status) == ChildCompleted + , Just resultValue <- row ^. #result -> + appendJournalEntry + (WorkflowName (row ^. #parentName)) + (WorkflowId (row ^. #parentId)) + StepRecorded + { stepName = row ^. #awaitStep + , result = childOkEnvelope resultValue + , recordedAt = fromMaybe (row ^. #updatedAt) (row ^. #completedAt) + } + -- The spawn already registered the link; nothing more to (re-)arm. + _ -> pure () + raw <- awaitStep resultStep arm + decodeChildResult childNm childWid (unStepName resultStep) raw + +-- --------------------------------------------------------------------------- +-- External control +-- --------------------------------------------------------------------------- + +{- | Cancel a child. For a @running@ child, flips its +@keiro_workflow_children@ row to @cancelled@ and, in the same transaction, +writes both the child's 'WorkflowCancelled' marker and the parent's +@{"cancelled": true}@ await-step sentinel. Returns 'True' only when this call +performed the row transition. For an already-@cancelled@ row, returns 'False' +but still ensures both markers, repairing historical crashes that committed the +row flip before either journal append. Already completed/failed/unknown +children return 'False' and no marker is fabricated. +-} +cancelChild :: + (IOE :> es, Store :> es) => + ChildHandle a -> + Eff es Bool +cancelChild (ChildHandle childNm childWid) = do + mrow <- lookupChild (unWorkflowId childWid) (unWorkflowName childNm) + case mrow of + Nothing -> pure False + Just row -> do + (transitioned, childOutcome, parentOutcome) <- ensureChildCancelled row + throwOnAppendConflict childOutcome + throwOnAppendConflict parentOutcome + pure transitioned + +-- --------------------------------------------------------------------------- +-- Completion propagation +-- --------------------------------------------------------------------------- + +{- | Drive a child workflow to completion, propagating its result to the parent. +This is 'runWorkflowWith' followed by 'childCompletionHook' on 'Completed': the +resume worker selects this (instead of bare 'runWorkflowWith') for any workflow +that is some parent's child, so a finished child wakes its waiting parent. A +'Suspended' child propagates nothing. A child row already marked 'ChildCancelled' +is repaired by ensuring the child cancellation marker and parent sentinel, then +returns 'Cancelled'; a 'ChildFailed' row returns 'Failed'. +-} +runChildWorkflow :: + (IOE :> es, Store :> es, Error StoreError :> es, ToJSON a) => + WorkflowRunOptions -> + WorkflowName -> + WorkflowId -> + Eff (Workflow : es) a -> + Eff es (WorkflowOutcome a) +runChildWorkflow opts childNm childWid action = do + mrow <- lookupChild (unWorkflowId childWid) (unWorkflowName childNm) + case fmap (^. #status) mrow of + Just ChildCancelled -> do + for_ mrow $ \row -> do + (_, childOutcome, parentOutcome) <- ensureChildCancelled row + throwOnAppendConflict childOutcome + throwOnAppendConflict parentOutcome + pure Cancelled + Just ChildFailed -> pure Failed + _ -> do + outcome <- runWorkflowWith opts childNm childWid action + case outcome of + Completed result -> do + childCompletionHook childNm childWid (toJSON result) + pure (Completed result) + other -> pure other + +{- | Propagate a finished child's result to its parent: flip the child row to +@completed@ (storing the raw result in the child row) and append an +@{"ok": result}@ @child:\:result@ 'StepRecorded' to the /parent/ +journal — exactly the wake source the parent's 'awaitChild' resolves on. The +running-row transition and parent append happen in one transaction. An +already-@completed@ row re-appends from the stored result, repairing historical +wedges; cancelled/failed children do not fabricate a success. Normally invoked +via 'runChildWorkflow'. +-} +childCompletionHook :: + (IOE :> es, Store :> es) => + WorkflowName -> + WorkflowId -> + Aeson.Value -> + Eff es () +childCompletionHook childNm childWid resultValue = do + mrow <- lookupChild (unWorkflowId childWid) (unWorkflowName childNm) + for_ mrow $ \row -> case row ^. #status of + Running -> do + now <- liftIO getCurrentTime + let parentName = WorkflowName (row ^. #parentName) + parentId = WorkflowId (row ^. #parentId) + gen <- currentGeneration parentName parentId + appendTx <- + prepareJournalAppend + parentName + parentId + gen + StepRecorded + { stepName = row ^. #awaitStep + , result = childOkEnvelope resultValue + , recordedAt = now + } + appendOutcome <- + runTransaction $ do + transitioned <- markChildResultTx (unWorkflowId childWid) (unWorkflowName childNm) resultValue now + if transitioned + then do + appendOutcome <- appendTx + condemnOnAppendConflict appendOutcome + pure appendOutcome + else pure (JournalAlreadyPresent resultValue) + throwOnAppendConflict appendOutcome + ChildCompleted -> + for_ (row ^. #result) $ \stored -> + appendJournalEntry + (WorkflowName (row ^. #parentName)) + (WorkflowId (row ^. #parentId)) + StepRecorded + { stepName = row ^. #awaitStep + , result = childOkEnvelope stored + , recordedAt = fromMaybe (row ^. #updatedAt) (row ^. #completedAt) + } + ChildCancelled -> pure () + ChildFailed -> pure () + +condemnOnAppendConflict :: JournalAppendOutcome -> Tx.Transaction () +condemnOnAppendConflict = \case + JournalAppendConflict{} -> Tx.condemn + _ -> pure () + +throwOnAppendConflict :: JournalAppendOutcome -> Eff es () +throwOnAppendConflict = \case + JournalAppendConflict err -> throwIO (WorkflowJournalAppendError (Text.pack (show err))) + _ -> pure () + +ensureChildCancelled :: + (IOE :> es, Store :> es) => + ChildRow -> + Eff es (Bool, JournalAppendOutcome, JournalAppendOutcome) +ensureChildCancelled row = do + now <- liftIO getCurrentTime + let childNm = WorkflowName (row ^. #childName) + childWid = WorkflowId (row ^. #childId) + parentNm = WorkflowName (row ^. #parentName) + parentWid = WorkflowId (row ^. #parentId) + childGen <- currentGeneration childNm childWid + parentGen <- currentGeneration parentNm parentWid + childAppendTx <- prepareJournalAppend childNm childWid childGen WorkflowCancelled{recordedAt = now} + parentAppendTx <- + prepareJournalAppend + parentNm + parentWid + parentGen + StepRecorded + { stepName = row ^. #awaitStep + , result = cancelledSentinel + , recordedAt = now + } + runTransaction $ do + transitioned <- + if row ^. #status == Running + then markChildCancelledTx (row ^. #childId) (row ^. #childName) + else pure False + if transitioned || row ^. #status == ChildCancelled + then do + childOutcome <- childAppendTx + parentOutcome <- parentAppendTx + condemnOnAppendConflict childOutcome + condemnOnAppendConflict parentOutcome + pure (transitioned, childOutcome, parentOutcome) + else pure (False, JournalAlreadyPresent Aeson.Null, JournalAlreadyPresent Aeson.Null) + +-- --------------------------------------------------------------------------- +-- The cancellation sentinel +-- --------------------------------------------------------------------------- + +{- | The @{"cancelled": true}@ value 'cancelChild' writes as a cancelled child's +await-step result so 'awaitChild' can detect it and throw. +-} +cancelledSentinel :: Aeson.Value +cancelledSentinel = Aeson.object ["cancelled" Aeson..= True] + +childOkEnvelope :: Aeson.Value -> Aeson.Value +childOkEnvelope value = Aeson.object ["ok" Aeson..= value] + +decodeChildResult :: + (FromJSON a) => + WorkflowName -> + WorkflowId -> + Text -> + Aeson.Value -> + Eff es a +decodeChildResult childNm childWid key raw = + case raw of + Aeson.Object obj + | Just okValue <- KeyMap.lookup "ok" obj -> + decodeOrThrow okValue + | Just (Aeson.Bool True) <- KeyMap.lookup "cancelled" obj -> + throwIO (WorkflowChildCancelled childNm childWid) + | Just (Aeson.String reason) <- KeyMap.lookup "failed" obj -> + throwIO (WorkflowChildFailed childNm childWid reason) + _ -> decodeOrThrow raw + where + decodeOrThrow value = + case Aeson.fromJSON value of + Aeson.Success a -> pure a + Aeson.Error e -> throwIO (WorkflowStepDecodeError key (Text.pack e)) diff --git a/src/Keiro/Workflow/Child/Schema.hs b/src/Keiro/Workflow/Child/Schema.hs new file mode 100644 --- /dev/null +++ b/src/Keiro/Workflow/Child/Schema.hs @@ -0,0 +1,315 @@ +{- | The @keiro_workflow_children@ table: durable parent↔child workflow links. + +Mirrors the @Keiro.Timer@ \/ @Keiro.Timer.Schema@ and +@Keiro.Workflow.Awakeable.Schema@ split: this module owns the row type, the +'ChildStatus' lifecycle, and the hasql statements; "Keiro.Workflow.Child" owns +the effectful spawn\/await\/cancel surface. + +* 'registerChildTx' inserts a @running@ row idempotently (the + @ON CONFLICT (child_id, child_name) DO NOTHING@ EP-38's @awaitStep@ arming + contract requires — a resumed parent re-runs the arm on every resume). +* 'lookupChild' \/ 'lookupChildrenOfParent' read rows back (operator + inspection and the @awaitChild@ arm's cancellation check). +* 'markChildResultTx' transitions a @running@ row to @completed@ (storing the + child's result), and 'markChildCancelledTx' transitions it to @cancelled@; + both guard on @status = 'running'@ so a double-resolve is a no-op. +* 'findRunningChildIds' is the resume worker's discovery seed for a zero-step + child (one that has been spawned but not yet driven, so has no + @keiro_workflow_steps@ rows for 'findUnfinishedWorkflowIds' to find). +* 'countActiveChildren' counts outstanding children — the seam EP-44 may read + for a @keiro.workflow.children.active@ gauge. + +Callers normally use the surface from "Keiro.Workflow.Child" rather than this +module directly. +-} +module Keiro.Workflow.Child.Schema ( + -- * Rows and status + ChildStatus (..), + ChildRow (..), + statusToText, + statusFromText, + + -- * Storage (run inside the caller's transaction) + registerChildTx, + markChildResultTx, + markChildCancelledTx, + markChildFailedTx, + + -- * Read-only lookups + lookupChild, + lookupChildrenOfParent, + childStatus, + countActiveChildren, + findRunningChildIds, +) +where + +import Contravariant.Extras (contrazip2, contrazip4, contrazip5) +import Effectful (Eff, (:>)) +import Hasql.Decoders qualified as D +import Hasql.Encoders qualified as E +import Hasql.Statement (Statement, preparable) +import Keiro.Prelude +import Kiroku.Store.Effect (Store) +import Kiroku.Store.Transaction (runTransaction) +import "hasql-transaction" Hasql.Transaction qualified as Tx + +{- | A child workflow's lifecycle, as seen from its parent. + +* 'Running' — spawned and not yet finished; the resume worker drives it. +* 'ChildCompleted' — the child reached its own 'Keiro.Workflow.WorkflowCompleted' + and its result was propagated to the parent journal; terminal. +* 'ChildCancelled' — the parent 'Keiro.Workflow.Child.cancelChild'led it; + terminal; also the decode fallback for an unrecognized stored value (the same + defensive choice "Keiro.Timer.Schema" makes). + +The constructors are prefixed @Child@ to avoid clashing with +'Keiro.Workflow.WorkflowOutcome''s @Completed@ and the awakeable\/timer +@Cancelled@ constructors. +-} +data ChildStatus + = Running + | ChildCompleted + | ChildCancelled + | ChildFailed + deriving stock (Generic, Eq, Show) + +{- | A child link row as stored: the child's (id, name), the parent's (id, +name), the parent-journal step the parent awaits ('awaitStep' = +@child:\:result@), the live 'status', the child's 'result' (set only +once 'ChildCompleted'), and the timestamps. +-} +data ChildRow = ChildRow + { childId :: !Text + , childName :: !Text + , parentId :: !Text + , parentName :: !Text + , awaitStep :: !Text + , status :: !ChildStatus + , result :: !(Maybe Value) + , createdAt :: !UTCTime + , updatedAt :: !UTCTime + , completedAt :: !(Maybe UTCTime) + } + deriving stock (Generic, Eq, Show) + +{- | Insert a @running@ child link row inside the caller's transaction, given +the child's @(id, name)@, the parent's @(id, name)@, and the parent-journal +step the parent awaits (@await_step@). Idempotent by +@ON CONFLICT (child_id, child_name) DO NOTHING@ — exactly what EP-38's "arm +must be idempotent" contract needs, since the spawn step and every resume's arm +re-run it. @status@, @result@, and the timestamps take their table defaults, so +no clock read is needed at the spawn site (mirrors +'Keiro.Workflow.Awakeable.Schema.registerAwakeableTx'). +-} +registerChildTx :: Text -> Text -> Text -> Text -> Text -> Tx.Transaction () +registerChildTx cid cname pid pname awaitStep = + Tx.statement (cid, cname, pid, pname, awaitStep) registerChildStmt + +{- | Transition a @running@ child to @completed@, storing @result@ and the +completion time, inside the caller's transaction. The @status = 'running'@ +guard makes a double-complete a no-op; returns 'True' only when this call +performed the transition. +-} +markChildResultTx :: Text -> Text -> Value -> UTCTime -> Tx.Transaction Bool +markChildResultTx cid cname result now = + Tx.statement (cid, cname, result, now) markChildResultStmt + +{- | Transition a @running@ child to @cancelled@ inside the caller's +transaction. Only @running@ rows match, so an already-completed (or +already-cancelled) child is left untouched and the call returns 'False'. +-} +markChildCancelledTx :: Text -> Text -> Tx.Transaction Bool +markChildCancelledTx cid cname = + Tx.statement (cid, cname) markChildCancelledStmt + +markChildFailedTx :: Text -> Text -> Tx.Transaction Bool +markChildFailedTx cid cname = + Tx.statement (cid, cname) markChildFailedStmt + +-- | Read a child link row by @(child_id, child_name)@. 'Nothing' if absent. +lookupChild :: (Store :> es) => Text -> Text -> Eff es (Maybe ChildRow) +lookupChild cid cname = + runTransaction (Tx.statement (cid, cname) lookupChildStmt) + +-- | Read every child link of a parent @(parent_id, parent_name)@. +lookupChildrenOfParent :: (Store :> es) => Text -> Text -> Eff es [ChildRow] +lookupChildrenOfParent pid pname = + runTransaction (Tx.statement (pid, pname) lookupChildrenOfParentStmt) + +-- | The 'ChildStatus' of a child by @(child_id, child_name)@, if it exists. +childStatus :: (Store :> es) => Text -> Text -> Eff es (Maybe ChildStatus) +childStatus cid cname = fmap (^. #status) <$> lookupChild cid cname + +{- | Count children currently @running@. Read-only. EP-44 may back a +@keiro.workflow.children.active@ gauge with this. +-} +countActiveChildren :: (Store :> es) => Eff es Int +countActiveChildren = + runTransaction (Tx.statement () countActiveChildrenStmt) + +{- | The @(child_id, child_name)@ of every @running@ child. The resume worker +unions this with 'Keiro.Workflow.findUnfinishedWorkflowIds' so a freshly +spawned child that has no @keiro_workflow_steps@ rows yet is still discovered +and driven. The tuple order matches 'findUnfinishedWorkflowIds' — @(id, name)@. +-} +findRunningChildIds :: (Store :> es) => Eff es [(Text, Text)] +findRunningChildIds = + runTransaction (Tx.statement () findRunningChildIdsStmt) + +registerChildStmt :: Statement (Text, Text, Text, Text, Text) () +registerChildStmt = + preparable + """ + INSERT INTO keiro.keiro_workflow_children + (child_id, child_name, parent_id, parent_name, await_step, status) + VALUES ($1, $2, $3, $4, $5, 'running') + ON CONFLICT (child_id, child_name) DO NOTHING + """ + ( contrazip5 + (E.param (E.nonNullable E.text)) + (E.param (E.nonNullable E.text)) + (E.param (E.nonNullable E.text)) + (E.param (E.nonNullable E.text)) + (E.param (E.nonNullable E.text)) + ) + D.noResult + +markChildResultStmt :: Statement (Text, Text, Value, UTCTime) Bool +markChildResultStmt = + preparable + """ + UPDATE keiro.keiro_workflow_children + SET status = 'completed', + result = $3, + completed_at = $4, + updated_at = now() + WHERE child_id = $1 + AND child_name = $2 + AND status = 'running' + """ + ( contrazip4 + (E.param (E.nonNullable E.text)) + (E.param (E.nonNullable E.text)) + (E.param (E.nonNullable E.jsonb)) + (E.param (E.nonNullable E.timestamptz)) + ) + ((> 0) <$> D.rowsAffected) + +markChildCancelledStmt :: Statement (Text, Text) Bool +markChildCancelledStmt = + preparable + """ + UPDATE keiro.keiro_workflow_children + SET status = 'cancelled', + updated_at = now() + WHERE child_id = $1 + AND child_name = $2 + AND status = 'running' + """ + ( contrazip2 + (E.param (E.nonNullable E.text)) + (E.param (E.nonNullable E.text)) + ) + ((> 0) <$> D.rowsAffected) + +markChildFailedStmt :: Statement (Text, Text) Bool +markChildFailedStmt = + preparable + """ + UPDATE keiro.keiro_workflow_children + SET status = 'failed', + updated_at = now() + WHERE child_id = $1 + AND child_name = $2 + AND status = 'running' + """ + ( contrazip2 + (E.param (E.nonNullable E.text)) + (E.param (E.nonNullable E.text)) + ) + ((> 0) <$> D.rowsAffected) + +lookupChildStmt :: Statement (Text, Text) (Maybe ChildRow) +lookupChildStmt = + preparable + """ + SELECT child_id, child_name, parent_id, parent_name, await_step, + status, result, created_at, updated_at, completed_at + FROM keiro.keiro_workflow_children + WHERE child_id = $1 + AND child_name = $2 + """ + ( contrazip2 + (E.param (E.nonNullable E.text)) + (E.param (E.nonNullable E.text)) + ) + (D.rowMaybe childRowDecoder) + +lookupChildrenOfParentStmt :: Statement (Text, Text) [ChildRow] +lookupChildrenOfParentStmt = + preparable + """ + SELECT child_id, child_name, parent_id, parent_name, await_step, + status, result, created_at, updated_at, completed_at + FROM keiro.keiro_workflow_children + WHERE parent_id = $1 + AND parent_name = $2 + ORDER BY created_at, child_id + """ + ( contrazip2 + (E.param (E.nonNullable E.text)) + (E.param (E.nonNullable E.text)) + ) + (D.rowList childRowDecoder) + +countActiveChildrenStmt :: Statement () Int +countActiveChildrenStmt = + preparable + """ + SELECT count(*) + FROM keiro.keiro_workflow_children + WHERE status = 'running' + """ + E.noParams + (D.singleRow (fromIntegral <$> D.column (D.nonNullable D.int8))) + +findRunningChildIdsStmt :: Statement () [(Text, Text)] +findRunningChildIdsStmt = + preparable + """ + SELECT child_id, child_name + FROM keiro.keiro_workflow_children + WHERE status = 'running' + """ + E.noParams + (D.rowList ((,) <$> D.column (D.nonNullable D.text) <*> D.column (D.nonNullable D.text))) + +childRowDecoder :: D.Row ChildRow +childRowDecoder = + ChildRow + <$> D.column (D.nonNullable D.text) + <*> D.column (D.nonNullable D.text) + <*> D.column (D.nonNullable D.text) + <*> D.column (D.nonNullable D.text) + <*> D.column (D.nonNullable D.text) + <*> (statusFromText <$> D.column (D.nonNullable D.text)) + <*> D.column (D.nullable D.jsonb) + <*> D.column (D.nonNullable D.timestamptz) + <*> D.column (D.nonNullable D.timestamptz) + <*> D.column (D.nullable D.timestamptz) + +statusToText :: ChildStatus -> Text +statusToText = \case + Running -> "running" + ChildCompleted -> "completed" + ChildCancelled -> "cancelled" + ChildFailed -> "failed" + +statusFromText :: Text -> ChildStatus +statusFromText = \case + "running" -> Running + "completed" -> ChildCompleted + "cancelled" -> ChildCancelled + "failed" -> ChildFailed + _ -> ChildCancelled diff --git a/src/Keiro/Workflow/Gc.hs b/src/Keiro/Workflow/Gc.hs new file mode 100644 --- /dev/null +++ b/src/Keiro/Workflow/Gc.hs @@ -0,0 +1,193 @@ +{- | Optional garbage collection for terminal workflow instances. + +The hot-path schema modules keep lifecycle writes and lookup statements. This +module owns only cleanup statements used by an operator-scheduled GC pass. +Eligibility is based on the derived @keiro_workflows@ row: terminal instances +older than the retention cutoff are deleted, except completed children whose +parent is still non-terminal and may still attach to their result. +-} +module Keiro.Workflow.Gc ( + WorkflowGcPolicy (..), + WorkflowGcSummary (..), + gcWorkflowsOnce, + runWorkflowGcWorker, +) +where + +import Contravariant.Extras (contrazip2, contrazip3, contrazip4) +import Control.Concurrent (threadDelay) +import Control.Monad (forever) +import Data.Int (Int32) +import Data.Time (NominalDiffTime, addUTCTime) +import Effectful (Eff, IOE, (:>)) +import Hasql.Decoders qualified as D +import Hasql.Encoders qualified as E +import Hasql.Statement (Statement, preparable) +import Keiro.Prelude +import Keiro.Workflow.Schema (currentGeneration) +import Keiro.Workflow.Types (WorkflowId (..), WorkflowName (..), workflowGenerationStreamName) +import Kiroku.Store.Effect (Store) +import Kiroku.Store.Lifecycle (hardDeleteStream) +import Kiroku.Store.Read (lookupStreamId) +import Kiroku.Store.Transaction (runTransaction) +import Kiroku.Store.Types (StreamId (..)) +import "hasql-transaction" Hasql.Transaction qualified as Tx + +data WorkflowGcPolicy = WorkflowGcPolicy + { retention :: !NominalDiffTime + , batchSize :: !Int + } + deriving stock (Generic, Eq, Show) + +data WorkflowGcSummary = WorkflowGcSummary + { scanned :: !Int + , deleted :: !Int + } + deriving stock (Generic, Eq, Show) + +gcWorkflowsOnce :: (Store :> es) => UTCTime -> WorkflowGcPolicy -> Eff es WorkflowGcSummary +gcWorkflowsOnce now policy = do + let cutoff = addUTCTime (negate (policy ^. #retention)) now + limit = max 0 (policy ^. #batchSize) + eligible <- runTransaction (Tx.statement (cutoff, fromIntegral limit :: Int32) eligibleWorkflowsStmt) + deletedCount <- length <$> traverse deleteWorkflow eligible + pure WorkflowGcSummary{scanned = length eligible, deleted = deletedCount} + +runWorkflowGcWorker :: (IOE :> es, Store :> es) => WorkflowGcPolicy -> Int -> Eff es () +runWorkflowGcWorker policy pollMicros = + forever $ do + now <- liftIO getCurrentTime + void (gcWorkflowsOnce now policy) + liftIO (threadDelay pollMicros) + +deleteWorkflow :: (Store :> es) => (Text, Text) -> Eff es () +deleteWorkflow (widText, nameText) = do + let name = WorkflowName nameText + wid = WorkflowId widText + gen <- currentGeneration name wid + for_ [0 .. gen] $ \generation -> do + let streamName = workflowGenerationStreamName name wid generation + mStreamId <- lookupStreamId streamName + for_ mStreamId $ \(StreamId sid) -> + runTransaction (Tx.statement sid deleteSnapshotStmt) + void (hardDeleteStream streamName) + runTransaction $ do + Tx.statement (widText, nameText) deleteStepsStmt + Tx.statement (nameText, widText) deleteAwakeablesStmt + Tx.statement (widText, nameText, widText, nameText) deleteChildrenStmt + -- Keep this literal in sync with Keiro.Workflow.Sleep.workflowSleepKind. + Tx.statement (widText, nameText, workflowSleepKindLiteral) deleteTerminalSleepTimersStmt + Tx.statement (widText, nameText) deleteWorkflowStmt + +workflowSleepKindLiteral :: Text +workflowSleepKindLiteral = "keiro.workflow.sleep" + +eligibleWorkflowsStmt :: Statement (UTCTime, Int32) [(Text, Text)] +eligibleWorkflowsStmt = + preparable + """ + SELECT w.workflow_id, w.workflow_name + FROM keiro.keiro_workflows w + WHERE w.status IN ('completed', 'cancelled', 'failed') + AND w.completed_at IS NOT NULL + AND w.completed_at <= $1 + AND NOT EXISTS ( + SELECT 1 + FROM keiro.keiro_workflow_children c + JOIN keiro.keiro_workflows p + ON p.workflow_id = c.parent_id + AND p.workflow_name = c.parent_name + WHERE c.child_id = w.workflow_id + AND c.child_name = w.workflow_name + AND p.status NOT IN ('completed', 'cancelled', 'failed') + ) + ORDER BY w.completed_at + LIMIT $2 + """ + ( contrazip2 + (E.param (E.nonNullable E.timestamptz)) + (E.param (E.nonNullable E.int4)) + ) + (D.rowList ((,) <$> D.column (D.nonNullable D.text) <*> D.column (D.nonNullable D.text))) + +deleteSnapshotStmt :: Statement Int64 () +deleteSnapshotStmt = + preparable + """ + DELETE FROM keiro.keiro_snapshots + WHERE stream_id = $1 + """ + (E.param (E.nonNullable E.int8)) + D.noResult + +deleteStepsStmt :: Statement (Text, Text) () +deleteStepsStmt = + preparable + """ + DELETE FROM keiro.keiro_workflow_steps + WHERE workflow_id = $1 AND workflow_name = $2 + """ + ( contrazip2 + (E.param (E.nonNullable E.text)) + (E.param (E.nonNullable E.text)) + ) + D.noResult + +deleteAwakeablesStmt :: Statement (Text, Text) () +deleteAwakeablesStmt = + preparable + """ + DELETE FROM keiro.keiro_awakeables + WHERE owner_workflow_name = $1 AND owner_workflow_id = $2 + """ + ( contrazip2 + (E.param (E.nonNullable E.text)) + (E.param (E.nonNullable E.text)) + ) + D.noResult + +deleteChildrenStmt :: Statement (Text, Text, Text, Text) () +deleteChildrenStmt = + preparable + """ + DELETE FROM keiro.keiro_workflow_children + WHERE (parent_id = $1 AND parent_name = $2) + OR (child_id = $3 AND child_name = $4) + """ + ( contrazip4 + (E.param (E.nonNullable E.text)) + (E.param (E.nonNullable E.text)) + (E.param (E.nonNullable E.text)) + (E.param (E.nonNullable E.text)) + ) + D.noResult + +deleteTerminalSleepTimersStmt :: Statement (Text, Text, Text) () +deleteTerminalSleepTimersStmt = + preparable + """ + DELETE FROM keiro.keiro_timers + WHERE correlation_id = $1 + AND process_manager_name = $2 + AND payload->>'kind' = $3 + AND status IN ('fired', 'cancelled', 'dead') + """ + ( contrazip3 + (E.param (E.nonNullable E.text)) + (E.param (E.nonNullable E.text)) + (E.param (E.nonNullable E.text)) + ) + D.noResult + +deleteWorkflowStmt :: Statement (Text, Text) () +deleteWorkflowStmt = + preparable + """ + DELETE FROM keiro.keiro_workflows + WHERE workflow_id = $1 AND workflow_name = $2 + """ + ( contrazip2 + (E.param (E.nonNullable E.text)) + (E.param (E.nonNullable E.text)) + ) + D.noResult diff --git a/src/Keiro/Workflow/Instance.hs b/src/Keiro/Workflow/Instance.hs new file mode 100644 --- /dev/null +++ b/src/Keiro/Workflow/Instance.hs @@ -0,0 +1,278 @@ +{- | Durable workflow instance summaries. + +The journal stream and @keiro_workflow_steps@ index remain the source of truth +for replay. This module maintains one @keiro_workflows@ row per logical +workflow instance so the resume worker can track lifecycle, attempts, and +leases without scanning journal history. +-} +module Keiro.Workflow.Instance ( + WorkflowStatus (..), + WorkflowInstanceRow (..), + statusToText, + statusFromText, + upsertInstanceTx, + markInstanceSuspended, + lookupInstance, + claimInstance, + releaseInstance, + recordCrashTx, + resetInstanceAttempts, +) +where + +import Contravariant.Extras (contrazip2, contrazip3, contrazip4, contrazip5) +import Data.Int (Int32) +import Data.Time (NominalDiffTime, addUTCTime) +import Effectful (Eff, IOE, (:>)) +import Hasql.Decoders qualified as D +import Hasql.Encoders qualified as E +import Hasql.Statement (Statement, preparable) +import Keiro.Prelude +import Keiro.Workflow.Schema (currentGeneration) +import Keiro.Workflow.Types (WorkflowId (..), WorkflowName (..)) +import Kiroku.Store.Effect (Store) +import Kiroku.Store.Transaction (runTransaction) +import "hasql-transaction" Hasql.Transaction qualified as Tx + +data WorkflowStatus + = WfRunning + | WfSuspended + | WfCompleted + | WfCancelled + | WfFailed + deriving stock (Generic, Eq, Show) + +data WorkflowInstanceRow = WorkflowInstanceRow + { workflowId :: !Text + , workflowName :: !Text + , generation :: !Int32 + , status :: !WorkflowStatus + , attempts :: !Int32 + , lastError :: !(Maybe Text) + , nextAttemptAt :: !(Maybe UTCTime) + , leasedBy :: !(Maybe Text) + , leaseExpiresAt :: !(Maybe UTCTime) + , createdAt :: !UTCTime + , updatedAt :: !UTCTime + , completedAt :: !(Maybe UTCTime) + } + deriving stock (Generic, Eq, Show) + +upsertInstanceTx :: Text -> Text -> Int32 -> WorkflowStatus -> Maybe Text -> Tx.Transaction () +upsertInstanceTx wid name gen status mLastError = + Tx.statement (wid, name, gen, statusToText status, mLastError) upsertInstanceStmt + +markInstanceSuspended :: (Store :> es) => WorkflowName -> WorkflowId -> Eff es () +markInstanceSuspended name@(WorkflowName nameText) wid@(WorkflowId widText) = do + gen <- currentGeneration name wid + runTransaction $ + upsertInstanceTx widText nameText (fromIntegral gen) WfSuspended Nothing + +lookupInstance :: (Store :> es) => WorkflowName -> WorkflowId -> Eff es (Maybe WorkflowInstanceRow) +lookupInstance (WorkflowName name) (WorkflowId wid) = + runTransaction (Tx.statement (wid, name) lookupInstanceStmt) + +claimInstance :: (IOE :> es, Store :> es) => Text -> NominalDiffTime -> WorkflowName -> WorkflowId -> Eff es Bool +claimInstance owner ttl name@(WorkflowName nameText) wid@(WorkflowId widText) = do + now <- liftIO getCurrentTime + gen <- currentGeneration name wid + runTransaction $ do + Tx.statement (widText, nameText, fromIntegral gen :: Int32) ensureInstanceStmt + fromMaybe False + <$> Tx.statement + (widText, nameText, owner, now, addUTCTime ttl now) + claimInstanceStmt + +releaseInstance :: (Store :> es) => Text -> Bool -> WorkflowName -> WorkflowId -> Eff es () +releaseInstance owner progressed (WorkflowName name) (WorkflowId wid) = + runTransaction $ + Tx.statement (wid, name, owner, progressed) releaseInstanceStmt + +recordCrashTx :: Text -> Text -> Text -> Tx.Transaction Int32 +recordCrashTx wid name err = + Tx.statement (wid, name, err) recordCrashStmt + +resetInstanceAttempts :: (Store :> es) => WorkflowName -> WorkflowId -> Eff es () +resetInstanceAttempts (WorkflowName name) (WorkflowId wid) = + runTransaction (Tx.statement (wid, name) resetInstanceAttemptsStmt) + +statusToText :: WorkflowStatus -> Text +statusToText = \case + WfRunning -> "running" + WfSuspended -> "suspended" + WfCompleted -> "completed" + WfCancelled -> "cancelled" + WfFailed -> "failed" + +statusFromText :: Text -> WorkflowStatus +statusFromText = \case + "running" -> WfRunning + "suspended" -> WfSuspended + "completed" -> WfCompleted + "cancelled" -> WfCancelled + "failed" -> WfFailed + _ -> WfFailed + +upsertInstanceStmt :: Statement (Text, Text, Int32, Text, Maybe Text) () +upsertInstanceStmt = + preparable + """ + INSERT INTO keiro.keiro_workflows + (workflow_id, workflow_name, generation, status, last_error, completed_at) + VALUES ($1, $2, $3, $4, $5, + CASE WHEN $4 IN ('completed', 'cancelled', 'failed') THEN now() ELSE NULL END) + ON CONFLICT (workflow_id, workflow_name) DO UPDATE + SET generation = GREATEST(keiro_workflows.generation, EXCLUDED.generation), + status = EXCLUDED.status, + last_error = EXCLUDED.last_error, + updated_at = now(), + completed_at = CASE + WHEN EXCLUDED.status IN ('completed', 'cancelled', 'failed') + THEN COALESCE(keiro_workflows.completed_at, now()) + ELSE keiro_workflows.completed_at + END + WHERE keiro_workflows.status NOT IN ('completed', 'cancelled', 'failed') + """ + ( contrazip5 + (E.param (E.nonNullable E.text)) + (E.param (E.nonNullable E.text)) + (E.param (E.nonNullable E.int4)) + (E.param (E.nonNullable E.text)) + (E.param (E.nullable E.text)) + ) + D.noResult + +lookupInstanceStmt :: Statement (Text, Text) (Maybe WorkflowInstanceRow) +lookupInstanceStmt = + preparable + """ + SELECT workflow_id, workflow_name, generation, status, attempts, + last_error, next_attempt_at, leased_by, lease_expires_at, + created_at, updated_at, completed_at + FROM keiro.keiro_workflows + WHERE workflow_id = $1 AND workflow_name = $2 + """ + ( contrazip2 + (E.param (E.nonNullable E.text)) + (E.param (E.nonNullable E.text)) + ) + (D.rowMaybe instanceRowDecoder) + +ensureInstanceStmt :: Statement (Text, Text, Int32) () +ensureInstanceStmt = + preparable + """ + INSERT INTO keiro.keiro_workflows + (workflow_id, workflow_name, generation, status) + VALUES ($1, $2, $3, 'running') + ON CONFLICT (workflow_id, workflow_name) DO NOTHING + """ + ( contrazip3 + (E.param (E.nonNullable E.text)) + (E.param (E.nonNullable E.text)) + (E.param (E.nonNullable E.int4)) + ) + D.noResult + +claimInstanceStmt :: Statement (Text, Text, Text, UTCTime, UTCTime) (Maybe Bool) +claimInstanceStmt = + preparable + """ + UPDATE keiro.keiro_workflows + SET leased_by = $3, + lease_expires_at = $5, + updated_at = $4 + WHERE workflow_id = $1 + AND workflow_name = $2 + AND status IN ('running', 'suspended') + AND (lease_expires_at IS NULL OR lease_expires_at < $4) + AND (next_attempt_at IS NULL OR next_attempt_at <= $4) + RETURNING TRUE + """ + ( contrazip5 + (E.param (E.nonNullable E.text)) + (E.param (E.nonNullable E.text)) + (E.param (E.nonNullable E.text)) + (E.param (E.nonNullable E.timestamptz)) + (E.param (E.nonNullable E.timestamptz)) + ) + (D.rowMaybe (D.column (D.nonNullable D.bool))) + +releaseInstanceStmt :: Statement (Text, Text, Text, Bool) () +releaseInstanceStmt = + preparable + """ + UPDATE keiro.keiro_workflows + SET leased_by = NULL, + lease_expires_at = NULL, + attempts = CASE WHEN $4 THEN 0 ELSE attempts END, + last_error = CASE WHEN $4 THEN NULL ELSE last_error END, + next_attempt_at = CASE WHEN $4 THEN NULL ELSE next_attempt_at END, + updated_at = now() + WHERE workflow_id = $1 + AND workflow_name = $2 + AND leased_by = $3 + """ + ( contrazip4 + (E.param (E.nonNullable E.text)) + (E.param (E.nonNullable E.text)) + (E.param (E.nonNullable E.text)) + (E.param (E.nonNullable E.bool)) + ) + D.noResult + +recordCrashStmt :: Statement (Text, Text, Text) Int32 +recordCrashStmt = + preparable + """ + UPDATE keiro.keiro_workflows + SET attempts = attempts + 1, + last_error = $3, + next_attempt_at = now() + (LEAST(power(2, attempts + 1), 64) * interval '1 second'), + updated_at = now() + WHERE workflow_id = $1 + AND workflow_name = $2 + AND status NOT IN ('completed', 'cancelled', 'failed') + RETURNING attempts + """ + ( contrazip3 + (E.param (E.nonNullable E.text)) + (E.param (E.nonNullable E.text)) + (E.param (E.nonNullable E.text)) + ) + (D.singleRow (D.column (D.nonNullable D.int4))) + +resetInstanceAttemptsStmt :: Statement (Text, Text) () +resetInstanceAttemptsStmt = + preparable + """ + UPDATE keiro.keiro_workflows + SET attempts = 0, + last_error = NULL, + next_attempt_at = NULL, + updated_at = now() + WHERE workflow_id = $1 + AND workflow_name = $2 + AND status NOT IN ('completed', 'cancelled', 'failed') + """ + ( contrazip2 + (E.param (E.nonNullable E.text)) + (E.param (E.nonNullable E.text)) + ) + D.noResult + +instanceRowDecoder :: D.Row WorkflowInstanceRow +instanceRowDecoder = + WorkflowInstanceRow + <$> D.column (D.nonNullable D.text) + <*> D.column (D.nonNullable D.text) + <*> D.column (D.nonNullable D.int4) + <*> (statusFromText <$> D.column (D.nonNullable D.text)) + <*> D.column (D.nonNullable D.int4) + <*> D.column (D.nullable D.text) + <*> D.column (D.nullable D.timestamptz) + <*> D.column (D.nullable D.text) + <*> D.column (D.nullable D.timestamptz) + <*> D.column (D.nonNullable D.timestamptz) + <*> D.column (D.nonNullable D.timestamptz) + <*> D.column (D.nullable D.timestamptz) diff --git a/src/Keiro/Workflow/Resume.hs b/src/Keiro/Workflow/Resume.hs new file mode 100644 --- /dev/null +++ b/src/Keiro/Workflow/Resume.hs @@ -0,0 +1,542 @@ +{- | The workflow resume / crash-recovery worker. + +EP-38 makes a workflow replay-on-re-invocation: call 'runWorkflow' (or +'runWorkflowWith') with the same id and each already-journaled step +short-circuits, so only the un-journaled tail runs. But nothing in the runtime +/notices/ that a workflow exists, has steps, and lacks a terminal +'WorkflowCompleted' — i.e. that it crashed mid-run, or is parked on a +@sleep@\/@awakeable@ whose wake source has since resolved. This module is what +notices: a background worker that, on each pass, asks the database "which +workflows have steps but no completion?" ('findUnfinishedWorkflowIds') and +re-invokes each so it proceeds. + +== Why a registry + +A workflow's body is application Haskell code — only its /journal/ (the +recorded step results) lives in the database. To re-invoke a workflow the +worker must turn its stored name into a function +@'WorkflowId' -> 'Eff' ('Workflow' : es) a@. There is no way to materialize a +closure from a string, so the application supplies a 'WorkflowRegistry' mapping +each 'WorkflowName' to its 'WorkflowDef'. This is the resume-worker analogue of +the caller-supplied @fire@ action 'Keiro.Timer.runTimerWorker' takes: the +worker owns the discovery loop and the database access; the application owns +the domain behaviour. + +== Contract recap for downstream plans (the v2 MasterPlan) + +* __'WorkflowRegistry' \/ 'WorkflowDef'__ — the application-supplied + name → definition map. EP-43 (child workflows) relies on this worker to wake + a /parent/ once a child finishes: the child's completion journals the + parent's awaited @child:\@ 'StepRecorded', and the next resume pass + re-invokes the parent (registered here) so it proceeds past its child-wait. +* __'ResumeSummary'__ ('discovered', 'resumed', 'completed', 'stillSuspended', + 'unknownName', 'failed', 'transientErrors', 'leaseSkipped') — the per-pass + observability record. EP-44 reads it for the @keiro.workflow.resumed@ + instrument (and may thread a @Maybe KeiroMetrics@ into + 'WorkflowResumeOptions' \/ 'resumeWorkflowsOnce' following the + no-op-under-@Nothing@ idiom the timer and outbox workers use). +* __'resumeWorkflowsOnce'__ is the single-pass, testable unit (like + 'Keiro.Outbox.publishClaimedOutbox'); __'runWorkflowResumeWorker'__ \/ + __'runWorkflowResumeWorkerWith'__ are the poll-loop drivers (like the + @runTimerWorker@ pair). Re-invocation goes through EP-41's 'runWorkflowWith' + carrying 'runOptions', so a resumed run honours the same snapshot/telemetry + options as its first run. + +Discovery is the 'findUnfinishedWorkflowIds' index query plus the child-row +seed query. Each candidate is claimed through an expiry-based row lease in +@keiro_workflows@ before it is advanced. A live foreign lease skips only that +instance and increments 'leaseSkipped'; a dead worker's lease becomes claimable +after 'leaseTtl'. The lease prevents duplicate steady-state work, while the +journal append path still serializes same-step writers so lease expiry races +converge on one recorded result. There is __no kiroku @wf:@ prefix +subscription__ and no session-level advisory lock. +-} +module Keiro.Workflow.Resume ( + -- * Registry + WorkflowDef (..), + WorkflowRegistry, + + -- * Options + WorkflowResumeOptions (..), + ResumeLogEvent (..), + defaultWorkflowResumeOptions, + + -- * Per-pass summary + ResumeSummary (..), + emptyResumeSummary, + + -- * Running (fixed-poll baseline) + resumeWorkflowsOnce, + runWorkflowResumeWorker, + runWorkflowResumeWorkerWith, + + -- * Running (push-aware, EP-50) + runPollLoopWith, + runWorkflowResumeWorkerPush, +) +where + +import Control.Concurrent (threadDelay) +import Control.Exception qualified as Exception +import Control.Monad (foldM, forever) +import Data.Aeson qualified as Aeson +import Data.IORef (newIORef, readIORef, writeIORef) +import Data.Map.Strict (Map) +import Data.Map.Strict qualified as Map +import Data.Set qualified as Set +import Data.Text qualified as Text +import Data.Time (NominalDiffTime) +import Data.UUID qualified as UUID +import Data.UUID.V4 qualified as UUIDv4 +import Effectful (Eff, IOE, (:>)) +import Effectful.Error.Static (Error) +import Effectful.Error.Static qualified as Error +import Effectful.Exception (catchSync, finally, throwIO) +import Keiro.Prelude +import Keiro.Telemetry ( + recordWorkflowAwakeablesPending, + recordWorkflowFailed, + recordWorkflowLeaseSkipped, + recordWorkflowResumeErrors, + recordWorkflowResumed, + ) +import Keiro.Wake (WakeSignal (..), wakeSignalFromStore) +import Keiro.Workflow ( + JournalAppendOutcome (..), + Workflow, + WorkflowError (..), + WorkflowId (..), + WorkflowJournalEvent (..), + WorkflowName (..), + WorkflowOutcome (..), + WorkflowRunOptions, + appendJournalEntry, + currentGeneration, + defaultWorkflowRunOptions, + findUnfinishedWorkflowIds, + prepareJournalAppend, + runWorkflowWith, + ) +import Keiro.Workflow.Awakeable.Schema (countPendingAwakeables) +import Keiro.Workflow.Child (runChildWorkflow) +import Keiro.Workflow.Child.Schema (ChildRow, findRunningChildIds, lookupChild, markChildFailedTx) +import Keiro.Workflow.Instance (claimInstance, recordCrashTx, releaseInstance) +import Kiroku.Store.Connection (KirokuStore) +import Kiroku.Store.Effect (Store, runStoreIO) +import Kiroku.Store.Error (StoreError) +import Kiroku.Store.Transaction (runTransaction) +import System.IO (hPutStrLn, stderr) +import "hasql-transaction" Hasql.Transaction qualified as Tx + +-- --------------------------------------------------------------------------- +-- Registry +-- --------------------------------------------------------------------------- + +{- | How to re-build a workflow's body from its id, for one workflow name. + +The result type @a@ is existential: the worker discards it (it cares only +whether a re-invocation reached 'Completed' or 'Suspended'), so one registry +can hold workflows of different return types. +-} +data WorkflowDef es = forall a. (Aeson.ToJSON a) => WorkflowDef + { runDef :: WorkflowId -> Eff (Workflow : es) a + } + +{- | The application-supplied map from workflow name to its definition. The +worker looks up each discovered workflow's name here; an absent name is +skipped and counted as 'unknownName' (a deploy that dropped a workflow while +instances were still in flight — surfaced, not silently lost). +-} +type WorkflowRegistry es = Map WorkflowName (WorkflowDef es) + +-- --------------------------------------------------------------------------- +-- Options +-- --------------------------------------------------------------------------- + +{- | Options for the resume worker. Mirrors the @TimerWorkerOptions@ shape: +'runOptions' threads EP-41's snapshot/telemetry options into 'runWorkflowWith', +and 'pollInterval' is the loop driver's gap between passes. +-} +data WorkflowResumeOptions = WorkflowResumeOptions + { runOptions :: !WorkflowRunOptions + {- ^ Threaded into 'runWorkflowWith' (or 'runChildWorkflow' for a child) so a + resumed run honours the same snapshot (EP-41) and telemetry (EP-44) + options as its first run. + -} + , pollInterval :: !Int + -- ^ Microseconds the loop driver sleeps between passes. + , maxAttempts :: !Int + -- ^ Workflow-level synchronous exceptions before terminal failure. + , leaseTtl :: !NominalDiffTime + -- ^ How long a claimed workflow instance stays leased if the worker dies mid-advance. + , logEvent :: !(ResumeLogEvent -> IO ()) + -- ^ Per-worker logging hook. Defaults to a compact stderr renderer. + } + deriving stock (Generic) + +data ResumeLogEvent + = ResumeUnknownName !Text !Text + | ResumeTransientError !Text !Text !Text + | ResumeWorkflowCrashed !Text !Text !Int !Int !Text + | ResumeWorkflowMarkedFailed !Text !Text !Text + | ResumePassFailed !Text + deriving stock (Eq, Show) + +-- | Defaults: EP-41's 'defaultWorkflowRunOptions', a 1-second poll, and a 60-second lease. +defaultWorkflowResumeOptions :: WorkflowResumeOptions +defaultWorkflowResumeOptions = + WorkflowResumeOptions + { runOptions = defaultWorkflowRunOptions + , pollInterval = 1_000_000 + , maxAttempts = 5 + , leaseTtl = 60 + , logEvent = defaultResumeLogEvent + } + +defaultResumeLogEvent :: ResumeLogEvent -> IO () +defaultResumeLogEvent event = + hPutStrLn stderr $ case event of + ResumeUnknownName name wid -> + "keiro resume worker: no registry entry for workflow " + <> Text.unpack name + <> " (id " + <> Text.unpack wid + <> "); skipping" + ResumeTransientError name wid err -> + "keiro resume worker: transient store error while advancing " + <> Text.unpack name + <> " (id " + <> Text.unpack wid + <> "): " + <> Text.unpack err + ResumeWorkflowCrashed name wid attempt maxAttempt err -> + "keiro resume worker: workflow " + <> Text.unpack name + <> " (id " + <> Text.unpack wid + <> ") crashed on attempt " + <> show attempt + <> "/" + <> show maxAttempt + <> ": " + <> Text.unpack err + ResumeWorkflowMarkedFailed name wid err -> + "keiro resume worker: marked workflow " + <> Text.unpack name + <> " (id " + <> Text.unpack wid + <> ") failed: " + <> Text.unpack err + ResumePassFailed err -> + "keiro resume worker: pass failed: " <> Text.unpack err + +-- --------------------------------------------------------------------------- +-- Per-pass summary +-- --------------------------------------------------------------------------- + +{- | What one 'resumeWorkflowsOnce' pass did. EP-44 instruments this for +@keiro.workflow.resumed@. +-} +data ResumeSummary = ResumeSummary + { discovered :: !Int + -- ^ Unfinished workflows 'findUnfinishedWorkflowIds' returned this pass. + , resumed :: !Int + -- ^ Workflows re-invoked (found in the registry and run). + , completed :: !Int + -- ^ Re-invocations that reached 'Completed' this pass. + , stillSuspended :: !Int + -- ^ Re-invocations that returned 'Suspended' (wake source not yet resolved). + , unknownName :: !Int + -- ^ Discovered workflows whose name was absent from the registry (skipped + logged). + , failed :: !Int + -- ^ Workflows marked terminally failed this pass. + , transientErrors :: !Int + -- ^ Store errors observed while advancing individual workflows. + , leaseSkipped :: !Int + -- ^ Candidates skipped because another worker holds a live lease. + } + deriving stock (Generic, Eq, Show) + +-- | A zeroed 'ResumeSummary'. +emptyResumeSummary :: ResumeSummary +emptyResumeSummary = ResumeSummary 0 0 0 0 0 0 0 0 + +-- --------------------------------------------------------------------------- +-- Running +-- --------------------------------------------------------------------------- + +{- | Run one discover-and-reinvoke pass. + +Discovers every unfinished workflow via 'findUnfinishedWorkflowIds', and for +each looks its name up in @registry@: + +* __present__ — re-invoke through 'runWorkflowWith' (the journal pre-load + short-circuits already-journaled steps, so only the un-journaled tail runs); + the outcome bumps 'completed' or 'stillSuspended'. +* __absent__ — log a warning and bump 'unknownName' (a workflow whose code was + removed while instances were in flight must be visible, not silently lost). + +Idempotent: a completed workflow has a @__workflow_completed__@ index row and +so drops out of discovery; re-invoking an unfinished one twice converges to the +same journal (EP-38 deterministic ids + step short-circuit). +-} +resumeWorkflowsOnce :: + forall es. + (IOE :> es, Store :> es, Error StoreError :> es) => + WorkflowResumeOptions -> + WorkflowRegistry es -> + Eff es ResumeSummary +resumeWorkflowsOnce opts registry = do + -- EP-44: sample the @keiro.workflow.awakeables.pending@ gauge once per pass, + -- on the same Store the discovery query uses. The metrics handle rides on the + -- run options (EP-44 threads telemetry through 'WorkflowRunOptions'), so it is + -- already forwarded into 'runWorkflowWith' for every re-invocation. + pending <- countPendingAwakeables + recordWorkflowAwakeablesPending mMetrics (fromIntegral pending) + -- Discovery unions two sources: workflows with steps but no terminal marker + -- ('findUnfinishedWorkflowIds') and freshly-spawned children that have no + -- step rows yet ('findRunningChildIds', EP-43) — so a zero-step child is + -- still driven. The dedup collapses a child that appears in both. + now <- liftIO getCurrentTime + unfinished <- findUnfinishedWorkflowIds now + runningChildren <- findRunningChildIds + let pairs = dedupeFirstSeen (unfinished <> runningChildren) + seed = emptyResumeSummary{discovered = length pairs} + owner <- UUID.toText <$> liftIO UUIDv4.nextRandom + foldM (advance owner) seed pairs + where + mMetrics = runOptions opts ^. #metrics + dedupeFirstSeen :: [(Text, Text)] -> [(Text, Text)] + dedupeFirstSeen = go Set.empty + where + go !_ [] = [] + go !seen (pair : rest) + | pair `Set.member` seen = go seen rest + | otherwise = pair : go (Set.insert pair seen) rest + + advance :: Text -> ResumeSummary -> (Text, Text) -> Eff es ResumeSummary + advance owner acc (widText, wnameText) = + case Map.lookup (WorkflowName wnameText) registry of + Nothing -> do + liftIO $ logEvent opts (ResumeUnknownName wnameText widText) + pure acc{unknownName = unknownName acc + 1} + Just (WorkflowDef runDef) -> do + let wid = WorkflowId widText + name = WorkflowName wnameText + claimed <- claimInstance owner (leaseTtl opts) name wid + if not claimed + then do + recordWorkflowLeaseSkipped mMetrics 1 + pure acc{leaseSkipped = leaseSkipped acc + 1} + else do + progressedRef <- liftIO (newIORef False) + ( do + attempt <- + Error.catchError + @StoreError + (AdvOk <$> driveInstance name wid runDef) + (\_ e -> pure (AdvTransient e)) + `catchSync` (pure . AdvCrashed) + recordWorkflowResumed mMetrics 1 + (acc', progressed) <- handleAttempt acc name wid attempt + liftIO (writeIORef progressedRef progressed) + pure acc' + ) + `finally` do + progressed <- liftIO (readIORef progressedRef) + releaseInstance owner progressed name wid + driveInstance :: (Aeson.ToJSON a) => WorkflowName -> WorkflowId -> (WorkflowId -> Eff (Workflow : es) a) -> Eff es (WorkflowOutcome a) + driveInstance name@(WorkflowName wnameText) wid@(WorkflowId widText) runDef = do + mChild <- lookupChild widText wnameText + case mChild of + Just _ -> runChildWorkflow (runOptions opts) name wid (runDef wid) + Nothing -> runWorkflowWith (runOptions opts) name wid (runDef wid) + handleAttempt :: ResumeSummary -> WorkflowName -> WorkflowId -> AdvanceResult a -> Eff es (ResumeSummary, Bool) + handleAttempt acc name@(WorkflowName wnameText) wid@(WorkflowId widText) = \case + AdvOk outcome -> do + pure (bumpForOutcome outcome acc, True) + AdvTransient err -> do + let rendered = Text.pack (show err) + liftIO $ logEvent opts (ResumeTransientError wnameText widText rendered) + recordWorkflowResumeErrors mMetrics 1 + pure (acc{resumed = resumed acc + 1, transientErrors = transientErrors acc + 1}, False) + AdvCrashed err -> do + let rendered = Text.pack (show err) + attempt <- runTransaction (recordCrashTx widText wnameText rendered) + liftIO $ logEvent opts (ResumeWorkflowCrashed wnameText widText (fromIntegral attempt) (maxAttempts opts) rendered) + if attempt >= fromIntegral (maxAttempts opts :: Int) + then do + now <- liftIO getCurrentTime + mChild <- lookupChild widText wnameText + case mChild of + Nothing -> + appendJournalEntry name wid (WorkflowFailed rendered now) + Just childRow -> + appendFailedChildAndWakeParent name wid rendered now childRow + liftIO $ logEvent opts (ResumeWorkflowMarkedFailed wnameText widText rendered) + recordWorkflowFailed mMetrics 1 + pure (acc{resumed = resumed acc + 1, failed = failed acc + 1}, False) + else pure (acc{resumed = resumed acc + 1}, False) + +data AdvanceResult a + = AdvOk !(WorkflowOutcome a) + | AdvTransient !StoreError + | AdvCrashed !Exception.SomeException + +appendFailedChildAndWakeParent :: + (IOE :> es, Store :> es) => + WorkflowName -> + WorkflowId -> + Text -> + UTCTime -> + ChildRow -> + Eff es () +appendFailedChildAndWakeParent childNm childWid reason now childRow = do + childGen <- currentGeneration childNm childWid + let parentNm = WorkflowName (childRow ^. #parentName) + parentWid = WorkflowId (childRow ^. #parentId) + parentGen <- currentGeneration parentNm parentWid + childFailTx <- prepareJournalAppend childNm childWid childGen (WorkflowFailed reason now) + parentWakeTx <- + prepareJournalAppend + parentNm + parentWid + parentGen + StepRecorded + { stepName = childRow ^. #awaitStep + , result = Aeson.object ["failed" Aeson..= reason] + , recordedAt = now + } + (childOutcome, parentOutcome) <- + runTransaction $ do + childOutcome <- childFailTx + _transitioned <- markChildFailedTx (unWorkflowId childWid) (unWorkflowName childNm) + parentOutcome <- parentWakeTx + condemnOnAppendConflict childOutcome + condemnOnAppendConflict parentOutcome + pure (childOutcome, parentOutcome) + throwOnAppendConflict childOutcome + throwOnAppendConflict parentOutcome + +condemnOnAppendConflict :: JournalAppendOutcome -> Tx.Transaction () +condemnOnAppendConflict = \case + JournalAppendConflict{} -> Tx.condemn + _ -> pure () + +throwOnAppendConflict :: JournalAppendOutcome -> Eff es () +throwOnAppendConflict = \case + JournalAppendConflict err -> throwIO (WorkflowJournalAppendError (Text.pack (show err))) + _ -> pure () + +{- | Fold one re-invocation's outcome into the running summary. The existential +result @a@ is discarded here, so it never escapes the registry. +-} +bumpForOutcome :: WorkflowOutcome a -> ResumeSummary -> ResumeSummary +bumpForOutcome outcome acc = case outcome of + Completed _ -> acc{resumed = resumed acc + 1, completed = completed acc + 1} + Suspended -> acc{resumed = resumed acc + 1, stillSuspended = stillSuspended acc + 1} + -- A workflow cancelled between discovery and re-invocation short-circuits to + -- 'Cancelled' (EP-43); count it as re-invoked but neither completed nor + -- suspended. (A cancelled workflow also drops out of discovery, so this is a + -- rare race, not the steady state.) + Cancelled -> acc{resumed = resumed acc + 1} + Failed -> acc{resumed = resumed acc + 1} + -- A workflow that rotated via continueAsNew (EP-48) returns 'ContinuedAsNew': + -- it is re-invoked but neither completed nor suspended this pass. Its new + -- generation has no terminal marker, so 'findUnfinishedWorkflowIds' still + -- reports it and the next pass drives the rotated generation forward. + ContinuedAsNew -> acc{resumed = resumed acc + 1} + +{- | Poll-and-resume loop: run 'resumeWorkflowsOnce' on the configured +'pollInterval' forever. Mirrors how an application schedules +'Keiro.Outbox.publishClaimedOutbox' \/ @runTimerWorker@ per tick; the +single-pass 'resumeWorkflowsOnce' remains the testable unit. +-} +runWorkflowResumeWorkerWith :: + (IOE :> es, Store :> es, Error StoreError :> es) => + WorkflowResumeOptions -> + WorkflowRegistry es -> + Eff es () +runWorkflowResumeWorkerWith opts registry = forever $ do + _summary <- + (Just <$> resumeWorkflowsOnce opts registry) + `Error.catchError` (\_ (e :: StoreError) -> logPass (Text.pack (show e))) + `catchSync` (logPass . Text.pack . show) + liftIO (threadDelay (pollInterval opts)) + where + logPass msg = do + liftIO $ logEvent opts (ResumePassFailed msg) + pure Nothing + +-- | 'runWorkflowResumeWorkerWith' with 'defaultWorkflowResumeOptions'. +runWorkflowResumeWorker :: + (IOE :> es, Store :> es, Error StoreError :> es) => + WorkflowRegistry es -> + Eff es () +runWorkflowResumeWorker = runWorkflowResumeWorkerWith defaultWorkflowResumeOptions + +-- --------------------------------------------------------------------------- +-- Push-aware loop (EP-50) +-- --------------------------------------------------------------------------- + +{- | Generic push-aware poll loop: run one pass, then block on the 'WakeSignal' +with the given fallback timeout (microseconds), forever. The pass is the durable +unit; the wake only shortens the gap between passes. Both wake reasons (a +notification or the fallback elapsing) mean "run another pass", so the returned +'Keiro.Wake.WakeReason' is ignored for control flow. A missed @NOTIFY@ costs at +most one fallback interval of latency, never lost work — correctness rests on the +pass (e.g. 'resumeWorkflowsOnce'), which is idempotent, not on a notification +arriving. The same pattern applies mechanically to 'Keiro.Timer.runTimerWorker' +and 'Keiro.Outbox.publishClaimedOutbox' (documented, not implemented here; the +resume worker carries the acceptance via parent/child cascades). +-} +runPollLoopWith :: + -- | the wake signal to block on between passes + WakeSignal -> + -- | fallback timeout in microseconds (the maximum gap when no notification arrives) + Int -> + -- | one pass, already wrapped to run in 'IO' + IO () -> + IO () +runPollLoopWith wake fallbackMicros pass = + forever (pass >> void (waitForWake wake fallbackMicros)) + +{- | The workflow resume worker, push-aware (EP-50). Runs 'resumeWorkflowsOnce' +on each pass; between passes it waits on the store's notifier (sub-second wake on +any append) and falls back to 'pollInterval' so a dropped notification still +drains the backlog. + +This is the push-aware sibling of 'runWorkflowResumeWorker' / +'runWorkflowResumeWorkerWith', which remain unchanged as the durable fixed-poll +baseline. The 'pollInterval' field is __repurposed__ as the /fallback/ timeout: +its meaning shifts from "fixed gap between passes" to "maximum gap when no +notification arrives" — strictly better for latency, identical in the +no-notification worst case. + +It opens __no__ new database connection (the 'WakeSignal' rides kiroku's existing +single per-store listener; see "Keiro.Wake"). It takes the 'KirokuStore' handle +directly to reach that notifier, and runs each pass through +'Kiroku.Store.Effect.runStoreIO', which pins the registry's effect row to the +concrete @'[Store, Error StoreError, IOE]@ that @runStoreIO@ eliminates. A caller +needing a richer effect row can use 'runPollLoopWith' directly with their own +@runStoreIO@-equivalent pass. +-} +runWorkflowResumeWorkerPush :: + KirokuStore -> + WorkflowResumeOptions -> + WorkflowRegistry '[Store, Error StoreError, IOE] -> + IO () +runWorkflowResumeWorkerPush store opts registry = do + wake <- wakeSignalFromStore store + runPollLoopWith wake (pollInterval opts) onePass + where + onePass = + handleSyncIO $ + runStoreIO store (resumeWorkflowsOnce opts registry) >>= \case + Left err -> logEvent opts (ResumePassFailed (Text.pack (show err))) + Right _ -> pure () + handleSyncIO action = + action `Exception.catch` \err -> + case Exception.fromException err of + Just (async :: Exception.SomeAsyncException) -> Exception.throwIO async + Nothing -> logEvent opts (ResumePassFailed (Text.pack (show (err :: Exception.SomeException)))) diff --git a/src/Keiro/Workflow/Schema.hs b/src/Keiro/Workflow/Schema.hs new file mode 100644 --- /dev/null +++ b/src/Keiro/Workflow/Schema.hs @@ -0,0 +1,255 @@ +{- | The @keiro_workflow_steps@ table: the derived index of journaled +workflow steps. + +The journal stream (@wf:\-\@) is the source of truth for replay; +this table is a fast-lookup view kept in sync inside the same transaction as +each journal append (see "Keiro.Workflow"). 'recordStepTx' upserts a row; +'loadStepIndex' reads an instance's recorded steps; 'stepExists' checks for +one step; 'findUnfinishedWorkflowIds' discovers resumable rows from +@keiro_workflows@ — the seam EP-42's resume worker builds on. + +Callers normally use the re-exports from "Keiro.Workflow" rather than this +module directly. +-} +module Keiro.Workflow.Schema ( + -- * Rows + WorkflowStepRow (..), + + -- * Storage + recordStepTx, + lookupStepResultTx, + lockWorkflowStepTx, + setWorkflowWakeAfterTx, + + -- * Read-only lookups + loadStepIndex, + stepExists, + currentGeneration, + findUnfinishedWorkflowIds, +) +where + +import Contravariant.Extras (contrazip2, contrazip3, contrazip4, contrazip6) +import Data.Int (Int32) +import Data.Map.Strict (Map) +import Data.Map.Strict qualified as Map +import Effectful (Eff, (:>)) +import Hasql.Decoders qualified as D +import Hasql.Encoders qualified as E +import Hasql.Statement (Statement, preparable) +import Keiro.Prelude +import Keiro.Workflow.Types (WorkflowId (..), WorkflowName (..)) +import Kiroku.Store.Effect (Store) +import Kiroku.Store.Transaction (runTransaction) +import "hasql-transaction" Hasql.Transaction qualified as Tx + +{- | A row of the @keiro_workflow_steps@ index: the workflow instance and +name, the step name, the step's JSON result, and when it was recorded. The +terminal completion marker is stored as a row whose 'stepName' is +'Keiro.Workflow.Types.completedStepName' and whose 'result' is JSON @null@. +-} +data WorkflowStepRow = WorkflowStepRow + { workflowId :: !Text + , workflowName :: !Text + , generation :: !Int + {- ^ EP-48: the journal /generation/ this step belongs to. Generation 0 is + the pre-rotation default; @continueAsNew@ rotates onto higher generations. + -} + , stepName :: !Text + , result :: !Value + , recordedAt :: !UTCTime + } + deriving stock (Generic, Eq, Show) + +{- | Upsert a step row inside the caller's transaction — an +@INSERT ... ON CONFLICT (workflow_id, step_name) DO NOTHING@, so a replayed +or raced write is a no-op. Called in the same transaction as the journal +append so the index and the journal stay consistent. +-} +recordStepTx :: WorkflowStepRow -> Tx.Transaction () +recordStepTx row = + Tx.statement + ( row ^. #workflowId + , row ^. #workflowName + , fromIntegral (row ^. #generation) :: Int32 + , row ^. #stepName + , row ^. #result + , row ^. #recordedAt + ) + recordStepStmt + +lookupStepResultTx :: Text -> Text -> Int -> Text -> Tx.Transaction (Maybe Value) +lookupStepResultTx wid name gen key = + Tx.statement (wid, name, fromIntegral gen :: Int32, key) lookupStepResultStmt + +lockWorkflowStepTx :: Text -> Tx.Transaction () +lockWorkflowStepTx key = + void (Tx.statement key lockWorkflowStepStmt) + +setWorkflowWakeAfterTx :: WorkflowName -> WorkflowId -> UTCTime -> Tx.Transaction () +setWorkflowWakeAfterTx (WorkflowName name) (WorkflowId wid) wakeAfter = + Tx.statement (wid, name, wakeAfter) setWorkflowWakeAfterStmt + +{- | Load every recorded step for a workflow instance as a @step name -> +result@ map (includes the terminal completion marker row if present). Exposed +for EP-42's resume worker; the replay handler in "Keiro.Workflow" pre-loads +from the journal stream instead. +-} +loadStepIndex :: (Store :> es) => WorkflowName -> WorkflowId -> Int -> Eff es (Map Text Value) +loadStepIndex (WorkflowName name) (WorkflowId wid) gen = + Map.fromList <$> runTransaction (Tx.statement (wid, name, fromIntegral gen :: Int32) loadStepIndexStmt) + +{- | Whether a workflow instance already has an index row for the given step +name. Used to make journal re-appends idempotent without relying on the event +store's duplicate-id rejection. +-} +stepExists :: (Store :> es) => WorkflowName -> WorkflowId -> Int -> Text -> Eff es Bool +stepExists (WorkflowName name) (WorkflowId wid) gen key = + runTransaction (Tx.statement (wid, name, fromIntegral gen :: Int32, key) stepExistsStmt) + +{- | The current (highest) generation recorded for a logical workflow, or 0 if +it has no step rows yet (EP-48). Index-supported by the +@(workflow_id, workflow_name, generation)@ lookup index. A workflow that never +rotates stays at generation 0 and behaves byte-for-byte as it did before EP-48. +A rotation commits the next generation's seed step under generation @g+1@ in +the same logical-id key space, so @MAX(generation)@ is unambiguously the +current generation. +-} +currentGeneration :: (Store :> es) => WorkflowName -> WorkflowId -> Eff es Int +currentGeneration (WorkflowName name) (WorkflowId wid) = + fromIntegral <$> runTransaction (Tx.statement (wid, name) currentGenerationStmt) + +{- | Return the @(workflow_id, workflow_name)@ of every non-terminal workflow +instance. Terminal statuses are @completed@, @cancelled@, and @failed@, matching +'Keiro.Workflow.Instance.WorkflowStatus'. The explicit time parameter is +reserved for wake-time filtering; today it keeps the call shape stable for that +addition. +-} +findUnfinishedWorkflowIds :: (Store :> es) => UTCTime -> Eff es [(Text, Text)] +findUnfinishedWorkflowIds now = + runTransaction (Tx.statement now findUnfinishedWorkflowIdsStmt) + +recordStepStmt :: Statement (Text, Text, Int32, Text, Value, UTCTime) () +recordStepStmt = + preparable + """ + INSERT INTO keiro.keiro_workflow_steps + (workflow_id, workflow_name, generation, step_name, result, recorded_at) + VALUES ($1, $2, $3, $4, $5, $6) + ON CONFLICT (workflow_id, workflow_name, generation, step_name) DO NOTHING + """ + ( contrazip6 + (E.param (E.nonNullable E.text)) + (E.param (E.nonNullable E.text)) + (E.param (E.nonNullable E.int4)) + (E.param (E.nonNullable E.text)) + (E.param (E.nonNullable E.jsonb)) + (E.param (E.nonNullable E.timestamptz)) + ) + D.noResult + +lookupStepResultStmt :: Statement (Text, Text, Int32, Text) (Maybe Value) +lookupStepResultStmt = + preparable + """ + SELECT result + FROM keiro.keiro_workflow_steps + WHERE workflow_id = $1 AND workflow_name = $2 AND generation = $3 AND step_name = $4 + """ + ( contrazip4 + (E.param (E.nonNullable E.text)) + (E.param (E.nonNullable E.text)) + (E.param (E.nonNullable E.int4)) + (E.param (E.nonNullable E.text)) + ) + (D.rowMaybe (D.column (D.nonNullable D.jsonb))) + +lockWorkflowStepStmt :: Statement Text Int32 +lockWorkflowStepStmt = + preparable + """ + SELECT 1::int4 FROM pg_advisory_xact_lock(hashtextextended($1, 0)) + """ + (E.param (E.nonNullable E.text)) + (D.singleRow (D.column (D.nonNullable D.int4))) + +loadStepIndexStmt :: Statement (Text, Text, Int32) [(Text, Value)] +loadStepIndexStmt = + preparable + """ + SELECT step_name, result + FROM keiro.keiro_workflow_steps + WHERE workflow_id = $1 AND workflow_name = $2 AND generation = $3 + """ + ( contrazip3 + (E.param (E.nonNullable E.text)) + (E.param (E.nonNullable E.text)) + (E.param (E.nonNullable E.int4)) + ) + (D.rowList ((,) <$> D.column (D.nonNullable D.text) <*> D.column (D.nonNullable D.jsonb))) + +stepExistsStmt :: Statement (Text, Text, Int32, Text) Bool +stepExistsStmt = + preparable + """ + SELECT EXISTS ( + SELECT 1 FROM keiro.keiro_workflow_steps + WHERE workflow_id = $1 AND workflow_name = $2 AND generation = $3 AND step_name = $4 + ) + """ + ( contrazip4 + (E.param (E.nonNullable E.text)) + (E.param (E.nonNullable E.text)) + (E.param (E.nonNullable E.int4)) + (E.param (E.nonNullable E.text)) + ) + (D.singleRow (D.column (D.nonNullable D.bool))) + +-- The current generation is MAX(generation) for the logical id+name, or 0 when +-- the workflow has no rows. Index-supported by keiro_workflow_steps_workflow_idx. +currentGenerationStmt :: Statement (Text, Text) Int32 +currentGenerationStmt = + preparable + """ + SELECT COALESCE(MAX(generation), 0)::int4 + FROM keiro.keiro_workflow_steps + WHERE workflow_id = $1 AND workflow_name = $2 + """ + ( contrazip2 + (E.param (E.nonNullable E.text)) + (E.param (E.nonNullable E.text)) + ) + (D.singleRow (D.column (D.nonNullable D.int4))) + +-- The terminal-status literals must match 'Keiro.Workflow.Instance.statusToText' +-- for completed, cancelled, and failed. The timestamp parameter makes +-- wake_after a self-expiring skip: future sleepers disappear from discovery +-- until their timer is due. +findUnfinishedWorkflowIdsStmt :: Statement UTCTime [(Text, Text)] +findUnfinishedWorkflowIdsStmt = + preparable + """ + SELECT workflow_id, workflow_name + FROM keiro.keiro_workflows + WHERE status NOT IN ('completed', 'cancelled', 'failed') + AND (wake_after IS NULL OR wake_after <= $1) + ORDER BY workflow_name, workflow_id + """ + (E.param (E.nonNullable E.timestamptz)) + (D.rowList ((,) <$> D.column (D.nonNullable D.text) <*> D.column (D.nonNullable D.text))) + +setWorkflowWakeAfterStmt :: Statement (Text, Text, UTCTime) () +setWorkflowWakeAfterStmt = + preparable + """ + UPDATE keiro.keiro_workflows + SET wake_after = $3, + updated_at = now() + WHERE workflow_id = $1 AND workflow_name = $2 + """ + ( contrazip3 + (E.param (E.nonNullable E.text)) + (E.param (E.nonNullable E.text)) + (E.param (E.nonNullable E.timestamptz)) + ) + D.noResult diff --git a/src/Keiro/Workflow/Sleep.hs b/src/Keiro/Workflow/Sleep.hs new file mode 100644 --- /dev/null +++ b/src/Keiro/Workflow/Sleep.hs @@ -0,0 +1,317 @@ +{- | Durable @sleep@ for workflows, backed by the existing @keiro_timers@ table. + +== What this gives you + +A workflow author can insert a durable pause between steps: + +@ +demo :: ('Workflow' ':>' es, 'Store' ':>' es, IOE ':>' es) => Eff es (Int, Int) +demo = do + a <- 'step' (StepName \"a\") (liftIO incr) -- side effect #1 + 'sleepNamed' (StepName \"cool\") 300 -- durable wait, survives a restart + b <- 'step' (StepName \"b\") (liftIO incr) -- side effect #2 + pure (a, b) +@ + +On the __first__ run, @demo@ executes @a@, journals it, arms a Postgres timer +for the sleep, and __suspends__ — 'Keiro.Workflow.runWorkflow' returns +'Suspended' and the journal @wf:demo-\@ 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:\\"}@ in its + @payload@ (see 'sleepTimerPayload' / 'parseSleepPayload'). This is how a + single timer worker distinguishes workflow sleeps from ordinary + process-manager timers and routes each correctly. + +* __Deterministic timer id.__ The timer id is a v5 UUID over + @(\"keiro\":\"workflow-sleep\":name:id:generation:sleepStepName)@ for + generation 1 and later, while generation 0 keeps the legacy + @(\"keiro\":\"workflow-sleep\":name:id:sleepStepName)@ shape. The workflow + sleep arm uses 'Keiro.Timer.scheduleTimerOnceTx', so the first arm's + @fire_at@ wins and every resume that re-enters the not-yet-resolved sleep + leaves the row untouched. The sleep duration is measured from the first arm, + not from the latest resume pass. + +* __No @keiro_timers@ schema change.__ Routing is entirely a function of the + caller-supplied fire action and the JSON payload; this module owns no + migration. + +* __A worker must drain the timers.__ A sleep only ever fires if some timer + worker runs 'workflowSleepFireAction' (via 'runWorkflowTimerWorker', or by + passing 'workflowSleepFireAction' directly to 'Keiro.Timer.runTimerWorker'). + A sleep whose timer is never drained — or one whose timer an operator + 'Keiro.Timer.cancelTimer's — stays suspended forever until an operator + intervenes. Workflow sleeps otherwise inherit the timer subsystem's recovery + surface ('Keiro.Timer.findStuckTimers' / 'Keiro.Timer.requeueStuckTimer' / + 'Keiro.Timer.deadLetterTimer') for free. +-} +module Keiro.Workflow.Sleep ( + -- * Authoring surface + sleepNamed, + sleep, + + -- * Firing and worker wiring + workflowSleepFireAction, + runWorkflowTimerWorker, + + -- * Timer id, payload, and step-name helpers + sleepTimerId, + sleepStepName, + sleepTimerPayload, + parseSleepPayload, + workflowSleepKind, +) +where + +import Data.Aeson (Value (..), object) +import Data.Aeson qualified as Aeson +import Data.Aeson.KeyMap qualified as KeyMap +import Data.Text qualified as Text +import Data.Time (NominalDiffTime, addUTCTime) +import Data.UUID.V5 qualified as UUID.V5 +import Effectful (Eff, IOE, (:>)) +import Keiro.Prelude +import Keiro.Telemetry (KeiroMetrics) +import Keiro.Timer ( + TimerId (..), + TimerRequest (..), + TimerRow, + runTimerWorker, + scheduleTimerOnceTx, + ) +import Keiro.Workflow ( + StepName (..), + Workflow, + WorkflowId (..), + WorkflowJournalEvent (..), + WorkflowName (..), + appendJournalEntryReturningId, + awaitStep, + currentRunGeneration, + currentWorkflow, + freshOrdinal, + setWorkflowWakeAfterTx, + sleepStepPrefix, + ) +import Kiroku.Store.Effect (Store) +import Kiroku.Store.Transaction (runTransaction) +import Kiroku.Store.Types (EventId) + +-- --------------------------------------------------------------------------- +-- Discriminator and payload +-- --------------------------------------------------------------------------- + +{- | The payload @"kind"@ tag that marks a 'keiro_timers' row as a workflow +sleep, distinguishing it from an ordinary process-manager timer so a single +timer worker can route each correctly. +-} +workflowSleepKind :: Text +workflowSleepKind = "keiro.workflow.sleep" + +{- | Build the JSON payload carried on a workflow-sleep timer row. The argument +is the full @"sleep:\"@ journal step name the firing will record. +-} +sleepTimerPayload :: Text -> Value +sleepTimerPayload fullStep = + object ["kind" Aeson..= workflowSleepKind, "step" Aeson..= fullStep] + +{- | Recognise and extract a workflow-sleep payload: @Just fullStep@ for a +payload this module wrote, 'Nothing' for any other timer (e.g. a process +manager's). The full step name returned is what the fire action journals. +-} +parseSleepPayload :: Value -> Maybe Text +parseSleepPayload = \case + Object o + | KeyMap.lookup "kind" o == Just (String workflowSleepKind) -> + case KeyMap.lookup "step" o of + Just (String s) -> Just s + _ -> Nothing + _ -> Nothing + +-- --------------------------------------------------------------------------- +-- Deterministic ids and step names +-- --------------------------------------------------------------------------- + +{- | The deterministic timer id for a sleep. Generation 0 keeps the legacy v5 +UUID over @(\"keiro\":\"workflow-sleep\":name:id:fullStep)@ so in-flight +pre-change timers remain signalable. Generations 1 and later include the +generation component so a sleep after 'Keiro.Workflow.continueAsNew' never +collides with a prior generation's terminal timer row. +-} +sleepTimerId :: WorkflowName -> WorkflowId -> Int -> Text -> TimerId +sleepTimerId name wid gen fullStep = + TimerId $ + UUID.V5.generateNamed UUID.V5.namespaceURL $ + fmap (fromIntegral . fromEnum) $ + Text.unpack $ + Text.intercalate + ":" + components + where + components + | gen <= 0 = + [ "keiro" + , "workflow-sleep" + , unWorkflowName name + , unWorkflowId wid + , fullStep + ] + | otherwise = + [ "keiro" + , "workflow-sleep" + , unWorkflowName name + , unWorkflowId wid + , Text.pack (show gen) + , fullStep + ] + +{- | The durable journal step name for a sleep: the user's suffix prefixed with +'sleepStepPrefix'. @'sleepStepName' (StepName \"cool\") == \"sleep:cool\"@. The +prefix keeps the journal self-describing — an operator scanning it sees +@sleep:@ and knows the entry is a durable wait, not an ordinary step. +-} +sleepStepName :: StepName -> Text +sleepStepName (StepName suffix) = sleepStepPrefix <> suffix + +-- --------------------------------------------------------------------------- +-- Authoring surface +-- --------------------------------------------------------------------------- + +{- | 'awaitStep' specialised to a 'Value' result. The recorded sleep completion +carries JSON @null@; 'Value''s 'FromJSON' is the identity, so any recorded +result decodes, which decouples the sleep from a @FromJSON ()@ instance. +-} +awaitValue :: (Workflow :> es) => StepName -> Eff es () -> Eff es Value +awaitValue = awaitStep + +{- | Durably pause the workflow for @delta@ under the stable name @userStep@. +On the first encounter this arms a deterministic 'keiro_timers' row and +suspends the run; the suspension resolves when a timer worker fires the row +(see 'workflowSleepFireAction') and journals the sleep's completion, after which +a later run replays past the sleep without re-arming. + +The arming action is idempotent (a resumed workflow re-runs it until the sleep +resolves): it inserts with a deterministic 'sleepTimerId' only when the row is +absent, so the first @fire_at@ persists across every resume pass. +-} +sleepNamed :: + (Workflow :> es, Store :> es, IOE :> es) => + StepName -> + NominalDiffTime -> + Eff es () +sleepNamed userStep delta = do + (name, wid) <- currentWorkflow + gen <- currentRunGeneration + let full = sleepStepName userStep + armedStep = StepName full + void . awaitValue armedStep $ do + now <- liftIO getCurrentTime + let request = + TimerRequest + { timerId = sleepTimerId name wid gen full + , processManagerName = unWorkflowName name + , correlationId = unWorkflowId wid + , fireAt = addUTCTime delta now + , payload = sleepTimerPayload full + } + -- Re-arms can only happen once discovery has found this instance again, + -- which means any existing wake_after has already self-expired. A later + -- overwrite is therefore bounded by the requested delay and suppresses + -- only future not-yet-due resume passes. + runTransaction (scheduleTimerOnceTx request >> setWorkflowWakeAfterTx name wid (request ^. #fireAt)) + +{- | Durably pause the workflow for @delta@ under an ordinal name (the @N@th +sleep in a run becomes @sleep:N@). Convenient but its determinism is +conditional — see the module header. Prefer 'sleepNamed' for anything that must +survive a code change mid-flight. +-} +sleep :: (Workflow :> es, Store :> es, IOE :> es) => NominalDiffTime -> Eff es () +sleep delta = do + n <- freshOrdinal "sleep" + sleepNamed (StepName (Text.pack (show n))) delta + +-- --------------------------------------------------------------------------- +-- Firing and worker wiring +-- --------------------------------------------------------------------------- + +{- | The fire action for workflow-sleep timers. For a 'TimerRow' whose payload +is a workflow-sleep discriminator, reconstruct the workflow identity from the +row's @processManagerName@ (= workflow name) and @correlationId@ (= workflow +id), append a @StepRecorded@ completion (@result = null@) to the workflow's +journal via 'appendJournalEntryReturningId', and return the appended 'EventId' +so the worker marks the timer @Fired@. Returns 'Nothing' for a row whose +payload is __not__ a workflow sleep, so a mixed worker can delegate that row to +its process-manager fire action. + +Idempotent: 'appendJournalEntryReturningId' pre-checks the step and returns the +same deterministic id on a re-fire, so at-least-once timer firing yields +exactly-once journaling. +-} +workflowSleepFireAction :: + (Store :> es, IOE :> es) => TimerRow -> Eff es (Maybe EventId) +workflowSleepFireAction row = + case parseSleepPayload (row ^. #payload) of + Nothing -> pure Nothing + Just full -> do + now <- liftIO getCurrentTime + let name = WorkflowName (row ^. #processManagerName) + wid = WorkflowId (row ^. #correlationId) + eid <- + appendJournalEntryReturningId + name + wid + (StepRecorded{stepName = full, result = Null, recordedAt = now}) + pure (Just eid) + +{- | A timer worker pass that handles __both__ workflow-sleep timers and +ordinary process-manager timers. For each claimed timer: if its payload is a +workflow sleep, wake the workflow; otherwise delegate to the supplied +process-manager fire action. + +A deployment that runs only workflows can pass @\\_ -> pure Nothing@ as the +fallback (or use 'workflowSleepFireAction' directly with +'Keiro.Timer.runTimerWorker'). A deployment that mixes process-manager timers +and workflow sleeps passes its existing PM fire action so one worker drains +both kinds. +-} +runWorkflowTimerWorker :: + (IOE :> es, Store :> es) => + Maybe KeiroMetrics -> + UTCTime -> + -- | Fallback fire action for non-sleep (process-manager) timers. + (TimerRow -> Eff es (Maybe EventId)) -> + Eff es (Maybe TimerRow) +runWorkflowTimerWorker metrics now pmFire = + runTimerWorker metrics now $ \row -> do + handled <- workflowSleepFireAction row + case handled of + Just eid -> pure (Just eid) + Nothing -> pmFire row diff --git a/src/Keiro/Workflow/Snapshot.hs b/src/Keiro/Workflow/Snapshot.hs new file mode 100644 --- /dev/null +++ b/src/Keiro/Workflow/Snapshot.hs @@ -0,0 +1,131 @@ +{- | Workflow journal snapshots: the workflow-specific 'StateCodec' and the +read\/write helpers the runtime uses to skip a full version-0 replay. + +A durable workflow folds its journal stream into a 'WorkflowState' — a +@'Map' 'Text' 'Value'@ of step-name to encoded result. For a long-lived +workflow, re-reading the whole journal on every run and resume is ruinous. +This module supplies the EP-4 snapshot machinery the runtime reuses to +persist that folded map and, on the next run, seed from it and replay only +the tail. + +== Why a workflow-specific codec + +EP-4's 'Keiro.Snapshot.Codec.defaultStateCodec' derives its 'shapeHash' from +a /statically-known/ keiki register-file slot list +('Keiki.Shape.regFileShapeHash'). A workflow's step names are dynamic runtime +strings, so there is no static slot list. The accumulated state is instead a +self-describing JSON object, so it round-trips through Aeson trivially and its +/shape/ never varies with which steps ran. Hence the fixed sentinel +'workflowStateShapeHash'; per-step result-type evolution is each step's own +'Aeson.ToJSON'\/'Aeson.FromJSON' concern, surfaced at the @step@ decode in +"Keiro.Workflow", not here. + +== Advisory semantics + +A snapshot is an optimization, never a source of truth. 'loadWorkflowSnapshot' +returns 'Nothing' — meaning "replay from version 0" — when the stream has no +id yet, no matching snapshot, or an undecodable snapshot. So a stale or corrupt +snapshot degrades performance at worst, never correctness. + +Runtime snapshot writes are advisory too. After a workflow journal append has +committed, "Keiro.Workflow" swallows any snapshot-store failure and increments +@keiro.snapshot.write.failures@; the committed step, completion, or rotation +therefore still determines a successful run. This low-level module continues +to expose the store primitive, while the runtime owns that error handling. + +Snapshot writes store the full accumulated step map each time the selected +policy fires. With an every-n policy that means rewriting the complete map at +each boundary; the intended way to bound that cost for forever-running +workflows is 'Keiro.Workflow.continueAsNew', which starts a fresh generation +with a small carried seed. +-} +module Keiro.Workflow.Snapshot ( + workflowStateCodec, + workflowStateCodecVersion, + workflowStateShapeHash, + lookupWorkflowSnapshot, + loadWorkflowSnapshot, + writeWorkflowSnapshot, +) +where + +import Data.Aeson (Result (..)) +import Data.Text qualified as Text +import Effectful (Eff, (:>)) +import Keiro.EventStream (StateCodec (..)) +import Keiro.Prelude +import Keiro.Snapshot (SnapshotMissReason (..), writeSnapshot) +import Keiro.Snapshot.Schema (lookupSnapshot) +import Keiro.Workflow.Types (WorkflowState) +import Kiroku.Store.Effect (Store) +import Kiroku.Store.Read (lookupStreamId) +import Kiroku.Store.Types (StreamId, StreamName, StreamVersion) + +{- | The codec version of the workflow snapshot envelope. Bumped only if the +map /envelope/ encoding itself changes (e.g. a switch from a bare JSON +object to a tagged container), never for a per-step result-type change. +-} +workflowStateCodecVersion :: Int +workflowStateCodecVersion = 1 + +{- | A FIXED sentinel shape hash. The accumulated state is always "a JSON +object of step-name strings to self-describing JSON values"; its /shape/ +never varies with which steps ran, so the shape hash is constant. Per-step +result-type evolution is the step's own 'Aeson.ToJSON'\/'Aeson.FromJSON' +concern, surfaced at the step decode in "Keiro.Workflow", not here. +-} +workflowStateShapeHash :: Text +workflowStateShapeHash = "keiro.workflow.stepmap.v1" + +{- | The workflow-specific 'StateCodec'. Encodes the accumulated +'WorkflowState' map straight to JSON and decodes it back, with a fixed +discriminant ('workflowStateCodecVersion', 'workflowStateShapeHash'). +-} +workflowStateCodec :: StateCodec WorkflowState +workflowStateCodec = + StateCodec + { stateCodecVersion = workflowStateCodecVersion + , shapeHash = workflowStateShapeHash + , encode = toJSON + , decode = \value -> case fromJSON value of + Success m -> Right m + Error msg -> Left (Text.pack msg) + } + +{- | Encode the accumulated map and upsert @keiro_snapshots@ for the journal +stream. Called from the @step@ miss-path (and the completion site) with the +'Kiroku.Store.Types.AppendResult'\'s @streamId@ and post-append @streamVersion@. +The underlying upsert keeps only the highest version per stream, so a re-fire +at an already-snapshotted version is a harmless no-op. +-} +writeWorkflowSnapshot :: (Store :> es) => StreamId -> StreamVersion -> WorkflowState -> Eff es () +writeWorkflowSnapshot streamId version state = + writeSnapshot streamId version workflowStateCodec state + +{- | Resolve the journal stream id, look up the latest matching snapshot row, +and decode it to a @('WorkflowState', 'StreamVersion')@ seed. Returns +'Nothing' — meaning "replay from 0" — when the stream has no id yet, no +matching snapshot, or an undecodable snapshot (advisory semantics). Mirrors +'Keiro.Snapshot.hydrateWithSnapshot''s miss-is-benign contract. +-} +loadWorkflowSnapshot :: (Store :> es) => StreamName -> Eff es (Maybe (WorkflowState, StreamVersion)) +loadWorkflowSnapshot journalName = + lookupWorkflowSnapshot journalName <&> either (const Nothing) Just + +{- | Resolve and decode a workflow snapshot while retaining the reason a +usable seed was unavailable. This is the observable counterpart to +'loadWorkflowSnapshot'. +-} +lookupWorkflowSnapshot :: (Store :> es) => StreamName -> Eff es (Either SnapshotMissReason (WorkflowState, StreamVersion)) +lookupWorkflowSnapshot journalName = do + mStreamId <- lookupStreamId journalName + case mStreamId of + Nothing -> pure (Left SnapshotNoStream) + Just streamId -> do + mRow <- lookupSnapshot streamId workflowStateCodecVersion workflowStateShapeHash + pure $ case mRow of + Nothing -> Left SnapshotNotFound + Just row -> + case (workflowStateCodec ^. #decode) (row ^. #state) of + Left message -> Left (SnapshotDecodeFailed message) + Right state -> Right (state, row ^. #streamVersion) diff --git a/src/Keiro/Workflow/Types.hs b/src/Keiro/Workflow/Types.hs new file mode 100644 --- /dev/null +++ b/src/Keiro/Workflow/Types.hs @@ -0,0 +1,407 @@ +{-# OPTIONS_GHC -Wno-partial-fields #-} + +{- | Core types and the journal codec for the durable workflow runtime. + +A /durable workflow/ is an ordinary @effectful@ computation whose side +effects are recorded ("journaled") at named checkpoints so the computation +can be paused and resumed across crashes without re-running work that +already happened. The journal is a kiroku stream named +@wf:\-\@ ('workflowStreamName') holding one +'StepRecorded' event per executed step and a terminal 'WorkflowCompleted' +event. + +This module owns the contracts every sibling plan of the v2 MasterPlan +builds on: the identity newtypes ('WorkflowName', 'WorkflowId', +'StepName'), the journal event sum ('WorkflowJournalEvent') and its +'Codec' ('workflowJournalCodec'), the accumulated-state alias +('WorkflowState'), the run outcome ('WorkflowOutcome'), and the +reserved step-name conventions ('completedStepName' plus the +@sleep:@\/@awk:@\/@child:@ prefixes). +-} +module Keiro.Workflow.Types ( + -- * Identity + WorkflowName (..), + WorkflowId (..), + WorkflowIdentityError (..), + mkWorkflowName, + mkWorkflowId, + StepName (..), + PatchId (..), + + -- * Stream naming + workflowStreamName, + workflowGenerationStreamName, + + -- * Journal events and codec + WorkflowJournalEvent (..), + workflowJournalCodec, + + -- * Accumulated state and run outcome + WorkflowState, + WorkflowOutcome (..), + + -- * Reserved step names + completedStepName, + cancelledStepName, + failedStepName, + continuedAsNewStepName, + continueSeedStepName, + sleepStepPrefix, + awakeableStepPrefix, + awakeableAllocStepPrefix, + childStepPrefix, + patchStepPrefix, + patchSetStepName, + patchStepName, +) +where + +import Data.Aeson qualified as Aeson +import Data.Aeson.Types (parseEither) +import Data.Bifunctor (first) +import Data.Map.Strict (Map) +import Data.Text qualified as Text +import Keiro.Codec (Codec (..)) +import Keiro.Prelude +import Kiroku.Store.Types (EventType (..), StreamName (..)) + +{- | The stable name of a workflow /definition/ (for example +@"orderFulfillment"@). Part of the journal stream name and of every +deterministic journal-event id, so it must not change for a given definition +across deploys. Prefer 'mkWorkflowName' for new code; the raw constructor is +kept for compatibility and can create ambiguous journal stream names if the +text contains structural separators such as @-@, @:@, or @#@. +-} +newtype WorkflowName = WorkflowName {unWorkflowName :: Text} + deriving stock (Eq, Ord, Show, Generic) + +{- | The id of a single workflow /instance/ (a UUID-as-text or any stable +caller-supplied string). Combined with the 'WorkflowName' it identifies the +instance's journal stream. Prefer 'mkWorkflowId' for new code; the raw +constructor is kept for compatibility and can create ambiguous journal stream +names if the text contains structural separators such as @:@ or @#@. +-} +newtype WorkflowId = WorkflowId {unWorkflowId :: Text} + deriving stock (Eq, Ord, Show, Generic) + +data WorkflowIdentityError + = WorkflowNameEmpty + | WorkflowNameInvalidChar !Char !Text + | WorkflowIdEmpty + | WorkflowIdInvalidChar !Char !Text + deriving stock (Eq, Show, Generic) + +{- | Validated constructor for workflow names. + +Rejects empty names and the structural separators @:@ (stream prefix), @-@ +(name/id boundary), and @#@ (generation suffix). Prefer camelCase compound +names such as @"orderFulfillment"@; the raw 'WorkflowName' constructor remains +available for compatibility. +-} +mkWorkflowName :: Text -> Either WorkflowIdentityError WorkflowName +mkWorkflowName raw + | Text.null raw = Left WorkflowNameEmpty + | Just c <- Text.find (`elem` ([':', '-', '#'] :: [Char])) raw = + Left (WorkflowNameInvalidChar c raw) + | otherwise = Right (WorkflowName raw) + +{- | Validated constructor for workflow ids. + +Rejects empty ids and the structural separators @:@ and @#@. The @-@ character +is permitted so UUID-style ids remain valid; with a validated, hyphen-free +workflow name, the @wf:\-\@ boundary is the first @-@. +-} +mkWorkflowId :: Text -> Either WorkflowIdentityError WorkflowId +mkWorkflowId raw + | Text.null raw = Left WorkflowIdEmpty + | Just c <- Text.find (`elem` ([':', '#'] :: [Char])) raw = + Left (WorkflowIdInvalidChar c raw) + | otherwise = Right (WorkflowId raw) + +{- | The label identifying a step within a workflow. Replay matches on this +label, not on source position, so reordering code between deploys does not +corrupt an in-flight workflow. +-} +newtype StepName = StepName {unStepName :: Text} + deriving stock (Eq, Ord, Show, Generic) + +{- | The stable identifier of a /patch/ (EP-49) — a guarded, cross-cutting change +to a running workflow's logic. The author chooses an opaque, never-reused string +(for example @"fraud-check-v2"@). A patch decision is journaled under the key +@patch:\@, 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:\-\@. + +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:\-\@ +convention carries the same caveat). +-} +workflowStreamName :: WorkflowName -> WorkflowId -> StreamName +workflowStreamName (WorkflowName name) (WorkflowId wid) = + StreamName ("wf:" <> name <> "-" <> wid) + +{- | The PHYSICAL journal stream for a given /generation/ of a logical +workflow (EP-48 continue-as-new). + +Generation 0 keeps the legacy name @wf:\-\@ — so already-running, +never-rotated workflows are byte-for-byte unchanged and need zero data +migration — while generation @g > 0@ appends a @#\@ suffix. The @#@ is a +new structural separator, distinct from the @:@ and @-@ that +'workflowStreamName' already reserves, so it cannot collide with an existing +boundary. The /logical/ identity @('WorkflowName', 'WorkflowId')@ the author +and the resume registry see is stable across rotations; only the physical +stream the journal lives on rotates underneath it. +-} +workflowGenerationStreamName :: WorkflowName -> WorkflowId -> Int -> StreamName +workflowGenerationStreamName name wid gen + | gen <= 0 = workflowStreamName name wid + | otherwise = + let StreamName base = workflowStreamName name wid + in StreamName (base <> "#" <> Text.pack (show gen)) + +{- | The events written to a workflow journal. + +* 'StepRecorded' — a step (identified by 'stepName') ran and produced + 'result' (the step's value encoded as JSON) at 'recordedAt'. The + suspension primitives journal their completions as ordinary + 'StepRecorded' events whose 'stepName' carries a reserved prefix + ('sleepStepPrefix', 'awakeableStepPrefix', 'childStepPrefix'); the + replay loop stays uniform because there is no separate event type. +* 'WorkflowCompleted' — the terminal marker appended once the whole + computation has returned. +* 'WorkflowCancelled' — a terminal marker (EP-43) written to a /child/ + workflow's journal by @cancelChild@; a run whose journal carries it + short-circuits without executing further steps and reports + 'Keiro.Workflow.Types.Cancelled'. +* 'WorkflowFailed' — a terminal failure marker (carries a 'reason'), + available for a worker to record a permanently-failed run. + +These last two are purely additive within @schemaVersion = 1@ (a new wire +tag added to 'workflowJournalCodec''s 'eventTypes'; old journals never carry +it, so no upcaster is needed). The codec is deliberately the single place to +extend. +-} +data WorkflowJournalEvent + = StepRecorded {stepName :: !Text, result :: !Aeson.Value, recordedAt :: !UTCTime} + | WorkflowCompleted {recordedAt :: !UTCTime} + | WorkflowCancelled {recordedAt :: !UTCTime} + | WorkflowFailed {reason :: !Text, recordedAt :: !UTCTime} + | {- | Terminal-for-this-generation rotation marker (EP-48). 'generation' + is the NEXT generation this rotation opens. Additive within + @schemaVersion = 1@: old journals never carry the + @"WorkflowContinuedAsNew"@ tag, so no upcaster is needed. + -} + WorkflowContinuedAsNew {generation :: !Int, recordedAt :: !UTCTime} + deriving stock (Eq, Show, Generic) + +{- | The 'Codec' that serializes 'WorkflowJournalEvent' to and from the +JSON payloads stored on the journal stream. Schema version 1; no +upcasters. Each payload is self-describing (it carries a @"kind"@ +discriminator) so 'decode' can reconstruct the constructor from the +payload alone. +-} +workflowJournalCodec :: Codec WorkflowJournalEvent +workflowJournalCodec = + Codec + { eventTypes = EventType "StepRecorded" :| [EventType "WorkflowCompleted", EventType "WorkflowCancelled", EventType "WorkflowFailed", EventType "WorkflowContinuedAsNew"] + , eventType = \case + StepRecorded{} -> EventType "StepRecorded" + WorkflowCompleted{} -> EventType "WorkflowCompleted" + WorkflowCancelled{} -> EventType "WorkflowCancelled" + WorkflowFailed{} -> EventType "WorkflowFailed" + WorkflowContinuedAsNew{} -> EventType "WorkflowContinuedAsNew" + , schemaVersion = 1 + , encode = encodeJournalEvent + , decode = decodeJournalEvent + , upcasters = [] + } + +encodeJournalEvent :: WorkflowJournalEvent -> Aeson.Value +encodeJournalEvent = \case + StepRecorded name r t -> + Aeson.object + [ "kind" Aeson..= ("StepRecorded" :: Text) + , "stepName" Aeson..= name + , "result" Aeson..= r + , "recordedAt" Aeson..= t + ] + WorkflowCompleted t -> + Aeson.object + [ "kind" Aeson..= ("WorkflowCompleted" :: Text) + , "recordedAt" Aeson..= t + ] + WorkflowCancelled t -> + Aeson.object + [ "kind" Aeson..= ("WorkflowCancelled" :: Text) + , "recordedAt" Aeson..= t + ] + WorkflowFailed r t -> + Aeson.object + [ "kind" Aeson..= ("WorkflowFailed" :: Text) + , "reason" Aeson..= r + , "recordedAt" Aeson..= t + ] + WorkflowContinuedAsNew g t -> + Aeson.object + [ "kind" Aeson..= ("WorkflowContinuedAsNew" :: Text) + , "generation" Aeson..= g + , "recordedAt" Aeson..= t + ] + +decodeJournalEvent :: EventType -> Aeson.Value -> Either Text WorkflowJournalEvent +decodeJournalEvent (EventType tag) value = first Text.pack (parseEither parser value) + where + parser = Aeson.withObject "WorkflowJournalEvent" $ \o -> do + case tag of + "StepRecorded" -> + StepRecorded <$> o Aeson..: "stepName" <*> o Aeson..: "result" <*> o Aeson..: "recordedAt" + "WorkflowCompleted" -> + WorkflowCompleted <$> o Aeson..: "recordedAt" + "WorkflowCancelled" -> + WorkflowCancelled <$> o Aeson..: "recordedAt" + "WorkflowFailed" -> + WorkflowFailed <$> o Aeson..: "reason" <*> o Aeson..: "recordedAt" + "WorkflowContinuedAsNew" -> + WorkflowContinuedAsNew <$> o Aeson..: "generation" <*> o Aeson..: "recordedAt" + other -> + fail ("unknown workflow journal event type: " <> Text.unpack other) + +{- | The accumulated step state a running workflow holds in memory: a map +from step name to that step's recorded JSON result. This is exactly the +value the journal carries, folded into a map. + +This alias is the integration contract EP-41 (snapshots) consumes; it must +remain a @Map Text Value@ whose keys are dynamic step-name strings. +-} +type WorkflowState = Map Text Aeson.Value + +{- | The result of running a workflow. + +* 'Completed' — the computation ran to its end and a 'WorkflowCompleted' + event was journaled. +* 'Suspended' — the computation paused at an unresolved @awaitStep@; a + wake source was armed and the run will be resumed later (by EP-42's + resume worker) once the awaited result is journaled. + +* 'Cancelled' — the run's journal carried a 'WorkflowCancelled' marker (a + child cancelled by its parent, EP-43), so the handler short-circuited and + executed nothing further. Distinct from 'Suspended' (which will resume) and + 'Completed' (which finished its work). +* 'Failed' — the run's journal carried a 'WorkflowFailed' marker, so the + handler short-circuited and executed nothing further. +-} +data WorkflowOutcome a + = Completed a + | Suspended + | Cancelled + | Failed + | {- | EP-48: the run rotated onto a fresh journal generation via + @continueAsNew@; a subsequent run/resume of the same logical id + continues from the carried seed. Distinct from 'Suspended' (a wake + source is pending) and 'Completed' (the workflow is done): a rotated + workflow is still unfinished, so the resume worker re-invokes it and it + proceeds on the new generation. + -} + ContinuedAsNew + deriving stock (Eq, Show, Functor) + +{- | The reserved step name written (as a 'WorkflowCompleted' journal event +and an index row) when a workflow finishes. The discovery query in +"Keiro.Workflow.Schema" ('Keiro.Workflow.Schema.findUnfinishedWorkflowIds') +treats a workflow lacking a row with this step name as unfinished, so the +literal here must match the literal in that SQL. +-} +completedStepName :: Text +completedStepName = "__workflow_completed__" + +{- | The reserved step name written (as a 'WorkflowCancelled' journal event and +an index row) when a workflow is cancelled. The replay handler short-circuits a +run that has a row with this step name, and +'Keiro.Workflow.Schema.findUnfinishedWorkflowIds' treats it (like +'completedStepName') as a terminal marker, so a cancelled workflow drops out of +resume discovery. The literal must match the literal in that SQL. +-} +cancelledStepName :: Text +cancelledStepName = "__workflow_cancelled__" + +{- | The reserved step name written (as a 'WorkflowFailed' journal event and an +index row) when a workflow is recorded as permanently failed. +-} +failedStepName :: Text +failedStepName = "__workflow_failed__" + +{- | The reserved step name written (as a 'WorkflowContinuedAsNew' journal event +and an index row) when a workflow's generation rotates via @continueAsNew@ +(EP-48). Its presence on a generation's index row makes that generation terminal +/for itself/ (a rotated-away generation drops out of any per-generation +"unfinished" check); the /current/ generation is the one with no terminal marker +row. Distinct from 'completedStepName'/'cancelledStepName': a rotated workflow is +NOT finished — its work continues on the next generation — +so 'Keiro.Workflow.Schema.findUnfinishedWorkflowIds' deliberately scopes its +terminal-marker check to the current (MAX) generation and does not treat +'continuedAsNewStepName' as terminal for the logical workflow. +-} +continuedAsNewStepName :: Text +continuedAsNewStepName = "__workflow_continued_as_new__" + +{- | The reserved step name under which @continueAsNew@ (EP-48) carries the +author's seed value into the next generation. On rotation the runtime appends a +single @StepRecorded continueSeedStepName seedJson@ to the next generation's +journal (and snapshots it); the next run's body reads it back via @restoreSeed@ +— an ordinary journaled @step@ — so the carried state is restored without +re-running anything. The leading/trailing @__@ marks it reserved, like the +other @__workflow_*__@ names. +-} +continueSeedStepName :: Text +continueSeedStepName = "__workflow_seed__" + +{- | Reserved step-name prefix EP-39 uses to journal a durable @sleep@'s +completion. Integration contract: EP-39 must use exactly this string. +-} +sleepStepPrefix :: Text +sleepStepPrefix = "sleep:" + +{- | Reserved step-name prefix EP-40 uses to journal an awakeable's +completion. Integration contract: EP-40 must use exactly this string. +-} +awakeableStepPrefix :: Text +awakeableStepPrefix = "awk:" + +{- | Reserved step-name prefix used to journal the random id allocated for an +awakeable. The id is random for new allocations but replay-stable because it is +recorded under @awkid:\@ before the workflow awaits @awk:\@. +-} +awakeableAllocStepPrefix :: Text +awakeableAllocStepPrefix = "awkid:" + +{- | Reserved step-name prefix EP-43 uses to journal a child workflow's +completion. Integration contract: EP-43 must use exactly this string. +-} +childStepPrefix :: Text +childStepPrefix = "child:" + +{- | Reserved step-name prefix EP-49 uses to journal a 'patch' decision. A patch +decision is journaled as an ordinary 'StepRecorded' event whose 'stepName' is +@'patchStepPrefix' <> 'unPatchId' pid@ and whose 'result' is the JSON 'Bool' +branch decision, so the replay loop and the step index stay uniform — no new +journal-event constructor is added. +-} +patchStepPrefix :: Text +patchStepPrefix = "patch:" + +{- | Reserved step name under which a workflow generation records the patch ids +that were active when that generation first started. +-} +patchSetStepName :: Text +patchSetStepName = "__workflow_patches__" + +-- | The journal key a patch decision is recorded under: @patch:\@. +patchStepName :: PatchId -> Text +patchStepName (PatchId pid) = patchStepPrefix <> pid diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,11054 @@ +module Main ( + main, +) +where + +import Contravariant.Extras (contrazip2, contrazip3, contrazip4, contrazip5, contrazip6) +import Control.Concurrent (forkIO, killThread, threadDelay) +import Control.Concurrent.MVar (MVar, modifyMVar, newEmptyMVar, newMVar, putMVar, readMVar, takeMVar, tryPutMVar) +import Control.Concurrent.STM (atomically, putTMVar) +import Control.Exception (Exception, SomeException, displayException, evaluate, finally, throwIO, try) +import Data.Aeson (object, withObject, (.:), (.:?)) +import Data.Aeson qualified as Aeson +import Data.Aeson.KeyMap qualified as KeyMap +import Data.Aeson.Types (parseEither) +import Data.ByteString (ByteString) +import Data.IORef (IORef, atomicModifyIORef', modifyIORef', newIORef, readIORef, writeIORef) +import Data.Int (Int32) +import Data.List (isInfixOf) +import Data.Map.Strict qualified as Map +import Data.Monoid (mempty) +import Data.Set qualified as Set +import Data.Text qualified as Text +import Data.Text.Encoding qualified as TE +import Data.Time (NominalDiffTime, UTCTime (..), addUTCTime, diffUTCTime, secondsToDiffTime) +import Data.Time.Calendar (Day (ModifiedJulianDay)) +import Data.UUID (UUID, fromString, fromWords64) +import Data.UUID qualified as UUID +import Data.Vector qualified as Vector +import Data.Word (Word64) +import Effectful (Eff, IOE, (:>)) +import Effectful.Error.Static (Error, throwError) +import GHC.Conc (ThreadStatus (..), threadStatus) +import Hasql.Decoders qualified as D +import Hasql.Encoders qualified as E +import Hasql.Statement (Statement, preparable) +import Keiki.Core ( + Edge (..), + HsPred (..), + InCtor (..), + IndexN, + RegFile (..), + SymTransducer (..), + Update (..), + WireCtor (..), + inpCtor, + matchInCtor, + oNil, + pack, + proj, + (*:), + (.==), + ) +import Keiki.Core qualified as Keiki +import Keiki.Generics (emptyRegFile) +import Keiro +import Keiro qualified as KeiroRoot +import Keiro.Connection (ensureProjectionSchema, qualifyTable, withProjectionSchema) +import Keiro.DeadLetter ( + DispatchDeadLetter (..), + DispatcherKind (..), + listDispatchDeadLetters, + recordDispatchDeadLetter, + ) +import Keiro.DeadLetter.Replay ( + ReplayOutcome (..), + ReplayResult (..), + listSubscriptionDeadLetters, + replaySubscriptionDeadLetters, + ) +import Keiro.EventStream (Terminality (..)) +import Keiro.EventStream.Validate ( + EventStreamWarning (..), + ValidatedEventStream, + mkEventStream, + mkEventStreamOrThrow, + mkEventStreamUnchecked, + mkEventStreamWith, + validateEventStream, + ) +import Keiro.Inbox ( + InboxDedupePolicy (..), + InboxError (..), + InboxPersistence (..), + InboxResult (..), + InboxStatus (..), + KafkaDeliveryRef (..), + garbageCollectCompleted, + listInbox, + lookupInbox, + markFailedTx, + runInboxTransaction, + runInboxTransactionBatch, + runInboxTransactionWith, + runInboxTransactionWithRetries, + runInboxTransactionWithRetriesWith, + sampleInboxBacklog, + ) +import Keiro.Inbox.Kafka qualified as InboxKafka +import Keiro.Integration.Event ( + IntegrationContentType (..), + IntegrationEvent (..), + SchemaReference (..), + TraceContext (..), + decodeJsonIntegrationEvent, + encodeJsonIntegrationEvent, + headerContentType, + headerMessageId, + headerSchemaSubject, + headerSchemaVersion, + headerSourceEventId, + headerSourceGlobalPosition, + headerTraceParent, + integrationHeaders, + integrationPayload, + parseContentType, + ) +import Keiro.Integration.Event qualified as IntegrationEvent +import Keiro.Outbox ( + BackoffSchedule (..), + ExponentialBackoffOptions (..), + IntegrationEventDraft (..), + IntegrationProducer (..), + IntegrationProducerConfigError (..), + OrderingPolicy (..), + OutboxId (..), + OutboxPublishConfigError (..), + OutboxRow (..), + OutboxStatus (..), + PublishOutcome (..), + claimOutboxBatch, + defaultMaintenanceOptions, + defaultPublishOptions, + draftToEvent, + enqueueIntegrationEventTx, + freshOutboxId, + garbageCollectSent, + lookupOutbox, + markOutboxSent, + mintIntegrationEvent, + mkIntegrationProducer, + mkOutboxPublishOptions, + outboxMaintenancePass, + publishClaimedOutbox, + sampleOutboxBacklog, + ) +import Keiro.Outbox.Kafka qualified as OutboxKafka +import Keiro.Outbox.Schema (markOutboxFailedTx) +import Keiro.Prelude +import Keiro.ProcessManager +import Keiro.Projection +import Keiro.ReadModel +import Keiro.ReadModel.Rebuild qualified as Rebuild +import Keiro.Snapshot.Policy (shouldSnapshot, shouldSnapshotSpan) +import Keiro.Stream qualified as Stream +import Keiro.Subscription.Shard ( + ShardCountMismatch (..), + ShardLease (..), + WorkerId (..), + ensureShards, + fairShareTarget, + ) +import Keiro.Subscription.Shard.Schema ( + claimShardsTx, + ensureShardRows, + listShardOwnership, + releaseShardsTx, + renewLeaseTx, + ) +import Keiro.Subscription.Shard.Worker ( + ShardAck (..), + ShardWorkerError (..), + ShardedWorkerConfigError (..), + ShardedWorkerOptions (..), + acquireOutcome, + defaultShardedWorkerOptions, + mkShardedWorkerOptions, + reconcileShardsOnce, + runShardedSubscriptionGroup, + runShardedSubscriptionGroupAck, + ) +import Keiro.Telemetry qualified as Telemetry +import Keiro.Test.Postgres ( + StoreRunner (..), + withFreshResourceStore, + withFreshResourceStoreWith, + withFreshStore, + withFreshStoreWith, + withFreshStores2, + withMigratedSuite, + ) +import Keiro.Timer +import Keiro.Wake ( + WakeReason (..), + WakeSignal (..), + neverWake, + wakeSignalFromStore, + ) +import Keiro.Workflow ( + PatchId (..), + StepName (..), + Workflow, + WorkflowError (..), + WorkflowId (..), + WorkflowIdentityError (..), + WorkflowJournalEvent (StepRecorded, WorkflowCancelled, WorkflowCompleted, WorkflowContinuedAsNew, WorkflowFailed), + WorkflowName (..), + WorkflowOutcome (..), + appendJournalEntry, + appendJournalEntryReturningId, + awaitStep, + awakeableAllocStepPrefix, + continueAsNew, + currentGeneration, + defaultWorkflowRunOptions, + findUnfinishedWorkflowIds, + loadStepIndex, + mkWorkflowId, + mkWorkflowName, + patch, + patchSetStepName, + patchStepName, + restoreSeed, + runWorkflow, + runWorkflowWith, + step, + stepExists, + workflowGenerationStreamName, + workflowJournalCodec, + ) +import Keiro.Workflow.Awakeable ( + AwakeableId (..), + WorkflowAwakeableCancelled (..), + awakeableIdText, + awakeableIdToUuid, + awakeableNamed, + cancelAwakeable, + deterministicAwakeableId, + signalAwakeable, + ) +import Keiro.Workflow.Awakeable.Schema qualified as Awk +import Keiro.Workflow.Child ( + ChildHandle (..), + WorkflowChildCancelled (..), + WorkflowChildFailed (..), + awaitChild, + cancelChild, + childCompletionHook, + childResultStepName, + childSpawnStepName, + runChildWorkflow, + spawnChild, + ) +import Keiro.Workflow.Child.Schema qualified as Child +import Keiro.Workflow.Gc qualified as WorkflowGc +import Keiro.Workflow.Instance qualified as Instance +import Keiro.Workflow.Resume ( + ResumeLogEvent (..), + ResumeSummary (..), + WorkflowDef (..), + defaultWorkflowResumeOptions, + emptyResumeSummary, + resumeWorkflowsOnce, + runPollLoopWith, + runWorkflowResumeWorkerPush, + runWorkflowResumeWorkerWith, + ) +import Keiro.Workflow.Sleep ( + parseSleepPayload, + runWorkflowTimerWorker, + sleepNamed, + sleepStepName, + sleepTimerId, + sleepTimerPayload, + workflowSleepFireAction, + ) +import Keiro.Workflow.Snapshot ( + loadWorkflowSnapshot, + workflowStateCodec, + ) +import Kiroku.Store qualified as Store +import Kiroku.Store.Effect (Store) +import Kiroku.Store.SQL qualified as KirokuSQL +import Kiroku.Store.Subscription.Stream (AckItem (..), subscriptionAckStream) +import Kiroku.Store.Subscription.Types ( + SubscriptionName (..), + SubscriptionTarget (..), + ) +import Kiroku.Store.Subscription.Types qualified as KirokuSub +import Kiroku.Store.Types ( + CategoryName (..), + EventData (..), + EventId (..), + EventType (..), + ExpectedVersion (..), + GlobalPosition (..), + RecordedEvent (..), + StreamId (..), + StreamName (..), + StreamVersion (..), + ) +import OpenTelemetry.Attributes (Attribute (..), Attributes, PrimitiveAttribute (..), lookupAttribute) +import OpenTelemetry.Attributes.Key (AttributeKey, unkey) +import OpenTelemetry.Exporter.InMemory.Metric (inMemoryMetricExporter) +import OpenTelemetry.Exporter.InMemory.Span (inMemoryListExporter) +import OpenTelemetry.Exporter.Metric ( + GaugeDataPoint (..), + HistogramDataPoint (..), + MetricExport (..), + NumberValue (..), + ResourceMetricsExport (..), + ScopeMetricsExport (..), + SumDataPoint (..), + ) +import OpenTelemetry.MeterProvider ( + SdkMeterProviderOptions (..), + createMeterProvider, + defaultSdkMeterProviderOptions, + ) +import OpenTelemetry.Metric.Core ( + forceFlushMeterProvider, + getMeter, + ) +import OpenTelemetry.Resource (emptyMaterializedResources) +import OpenTelemetry.Trace ( + SpanStatus (..), + createTracerProvider, + emptyTracerProviderOptions, + makeTracer, + shutdownTracerProvider, + tracerOptions, + ) +import OpenTelemetry.Trace.Core ( + ImmutableSpan (..), + Span, + SpanContext (..), + SpanHot (..), + SpanKind, + getSpanContext, + ) +import Shibuya.Adapter (Adapter (..)) +import Shibuya.Core.Ack (AckDecision (..), DeadLetterReason (..), HaltReason (..), RetryDelay (..)) +import Shibuya.Core.AckHandle (AckHandle (..)) +import Shibuya.Core.Ingested (Ingested (..)) +import Shibuya.Core.Types (Envelope (..)) +import Streamly.Data.Stream qualified as Streamly +import System.Exit (ExitCode (..)) +import System.Process (readProcessWithExitCode) +import System.Timeout (timeout) +import Test.Hspec +import "hasql-transaction" Hasql.Transaction qualified as Tx + +main :: IO () +main = withMigratedSuite $ \fixture -> hspec $ do + describe "Keiro" $ do + it "exposes the scaffold version" $ + KeiroRoot.version `shouldBe` ("0.1.0.0" :: Text) + + describe "Keiro.Telemetry metrics" $ do + it "records instrument names and values through an SDK meter" $ do + (exporter, ref) <- inMemoryMetricExporter + (provider, _env) <- + createMeterProvider + emptyMaterializedResources + defaultSdkMeterProviderOptions{metricExporter = Just exporter} + meter <- getMeter provider Telemetry.keiroInstrumentationLibrary + metrics <- Telemetry.newKeiroMetrics meter + let h = Just metrics + -- A counter (monotonic sum), a gauge (last value wins), a histogram. + Telemetry.recordOutboxPublished h 3 + Telemetry.recordOutboxPublished h 2 + Telemetry.recordOutboxBacklog h 7 + Telemetry.recordInboxDuplicates h 1 + Telemetry.recordTimerFireLag h 12.5 + _ <- forceFlushMeterProvider provider Nothing + exported <- readIORef ref + let scalars = flattenScalarPoints exported + hists = flattenHistogramPoints exported + -- The counter accumulated 3 + 2 = 5. + lookup "keiro.outbox.published" scalars `shouldBe` Just (IntNumber 5) + -- The gauge holds its last recorded value. + lookup "keiro.outbox.backlog" scalars `shouldBe` Just (IntNumber 7) + -- The duplicate counter holds 1. + lookup "keiro.inbox.duplicates" scalars `shouldBe` Just (IntNumber 1) + -- The histogram saw one observation summing to 12.5. + let lag = [(c, s) | (n, c, s) <- hists, n == "keiro.timer.fire.lag"] + lag `shouldBe` [(1, 12.5)] + -- Instruments we never recorded export no points. + lookup "keiro.timer.stuck" scalars `shouldBe` Nothing + + it "records nothing through a Nothing handle" $ do + (exporter, ref) <- inMemoryMetricExporter + (provider, _env) <- + createMeterProvider + emptyMaterializedResources + defaultSdkMeterProviderOptions{metricExporter = Just exporter} + -- A Nothing handle is the no-op path: helpers must short-circuit. + let h = Nothing + Telemetry.recordOutboxPublished h 99 + Telemetry.recordOutboxBacklog h 99 + Telemetry.recordTimerFireLag h 99.0 + _ <- forceFlushMeterProvider provider Nothing + exported <- readIORef ref + flattenScalarPoints exported `shouldBe` [] + flattenHistogramPoints exported `shouldBe` [] + + describe "Kiroku retry exhaustion observability" $ do + it "dead-letters after the configured delivery bound, emits the metric, and advances" $ do + (exporter, metricsRef) <- inMemoryMetricExporter + (provider, _env) <- + createMeterProvider + emptyMaterializedResources + defaultSdkMeterProviderOptions{metricExporter = Just exporter} + meter <- getMeter provider Telemetry.keiroInstrumentationLibrary + metrics <- Telemetry.newKeiroMetrics meter + forwarded <- newIORef (0 :: Int) + let observe _ = modifyIORef' forwarded (+ 1) + installBridge settings = + settings + & #eventHandler + .~ Just (Telemetry.kirokuEventBridge (Just metrics) observe) + withFreshStoreWith fixture installBridge $ \store -> do + total <- seedOrders store 1 2 + total `shouldBe` 2 + let subName = SubscriptionName "orders-retry-exhaustion" + subConfig = + ( KirokuSub.defaultSubscriptionConfig + subName + (Category (CategoryName "orders")) + (\_ -> pure KirokuSub.Continue) + ) + { KirokuSub.retryPolicy = KirokuSub.RetryPolicy 2 + } + pull label source = do + result <- timeout 5_000_000 (Streamly.uncons source) + case result of + Just (Just itemAndRest) -> pure itemAndRest + Just Nothing -> fail (label <> ": subscription ended early") + Nothing -> fail (label <> ": timed out waiting for delivery") + number item = + parseEither + (withObject "OrderPlaced" (.: "n")) + (ackEvent item ^. #payload) + (stream0, cancelStream) <- subscriptionAckStream store subConfig 4 + ( do + (first, stream1) <- pull "initial poison delivery" stream0 + ackAttempt first `shouldBe` 0 + number first `shouldBe` Right (0 :: Int) + atomically $ + putTMVar + (ackReply first) + (KirokuSub.Retry (KirokuSub.RetryDelay 0)) + + (retry, stream2) <- pull "poison redelivery" stream1 + ackAttempt retry `shouldBe` 1 + ackEvent retry ^. #eventId `shouldBe` ackEvent first ^. #eventId + atomically $ + putTMVar + (ackReply retry) + (KirokuSub.Retry (KirokuSub.RetryDelay 0)) + + (next, stream3) <- pull "event after exhausted poison" stream2 + ackAttempt next `shouldBe` 0 + number next `shouldBe` Right (1 :: Int) + ackEvent next ^. #eventId `shouldNotBe` ackEvent first ^. #eventId + atomically (putTMVar (ackReply next) KirokuSub.Stop) + ended <- timeout 5_000_000 (Streamly.uncons stream3) + case ended of + Just Nothing -> pure () + Just (Just _) -> expectationFailure "subscription delivered after Stop" + Nothing -> expectationFailure "subscription did not stop after the final acknowledgement" + ) + `finally` cancelStream + + Right rows <- + Store.runStoreIO store $ + Store.runTransaction $ + Tx.statement + ("orders-retry-exhaustion", 0) + KirokuSQL.readDeadLettersStmt + case Vector.toList rows of + [row] -> do + row ^. #deadLetterReason + `shouldBe` object + [ "kind" Aeson..= ("max_attempts_exceeded" :: Text) + , "attempts" Aeson..= (2 :: Int) + ] + row ^. #deadLetterReasonSummary `shouldBe` "max retry attempts exceeded (2)" + row ^. #deadLetterAttemptCount `shouldBe` 2 + other -> expectationFailure ("expected one Kiroku dead letter, got " <> show (Vector.length rows) <> ": " <> show other) + + _ <- forceFlushMeterProvider provider Nothing + exported <- readIORef metricsRef + lookup "keiro.subscription.deadlettered" (flattenScalarPoints exported) + `shouldBe` Just (IntNumber 1) + readIORef forwarded >>= (`shouldSatisfy` (> 1)) + + describe "Keiro.Stream" $ do + it "wraps and unwraps kiroku stream names" $ do + let orderStream = stream "order-123" :: Stream OrderStream + Stream.streamName orderStream `shouldBe` StreamName "order-123" + Stream.streamName (mapStreamName (\(StreamName name) -> StreamName (name <> "-archived")) orderStream) + `shouldBe` StreamName "order-123-archived" + + it "validates categories, rejecting the dash boundary and reserved names" $ do + fmap Stream.categoryText (Stream.category "incident" :: Either Stream.CategoryError (Stream.StreamCategory ())) + `shouldBe` Right "incident" + -- compound categories are camelCase; ':' (reserved for the wf: family) is also accepted + fmap Stream.categoryText (Stream.category "hospitalSurge" :: Either Stream.CategoryError (Stream.StreamCategory ())) + `shouldBe` Right "hospitalSurge" + fmap Stream.categoryText (Stream.category "wf:fulfillment" :: Either Stream.CategoryError (Stream.StreamCategory ())) + `shouldBe` Right "wf:fulfillment" + (Stream.category "" :: Either Stream.CategoryError (Stream.StreamCategory ())) + `shouldBe` Left Stream.CategoryEmpty + (Stream.category "hospital-surge" :: Either Stream.CategoryError (Stream.StreamCategory ())) + `shouldBe` Left (Stream.CategoryContainsSeparator "hospital-surge") + (Stream.category "$all" :: Either Stream.CategoryError (Stream.StreamCategory ())) + `shouldBe` Left (Stream.CategoryReserved "$all") + (Stream.category "ord ers" :: Either Stream.CategoryError (Stream.StreamCategory ())) + `shouldBe` Left (Stream.CategoryContainsIllegalChar ' ' "ord ers") + (Stream.category "ord\ners" :: Either Stream.CategoryError (Stream.StreamCategory ())) + `shouldBe` Left (Stream.CategoryContainsIllegalChar '\n' "ord\ners") + + it "builds entity streams that round-trip through kiroku's category rule" $ do + let cat = Stream.categoryUnsafe "orders" :: Stream.StreamCategory OrderStream + Stream.streamName (Stream.entityStream cat "1") `shouldBe` StreamName "orders-1" + Stream.categoryName cat `shouldBe` CategoryName "orders" + -- The category keiro reports equals kiroku's own parse of the produced + -- name, even when the id segment itself contains a dash. + Store.categoryName (Stream.streamName (Stream.entityStream cat "a-b-c")) + `shouldBe` Stream.categoryName cat + + it "entityStreamId renders ids via StreamIdSegment (Text and String)" $ do + let cat = Stream.categoryUnsafe "orders" :: Stream.StreamCategory OrderStream + Stream.streamName (Stream.entityStreamId cat ("o-1" :: Text)) `shouldBe` StreamName "orders-o-1" + Stream.streamName (Stream.entityStreamId cat ("o-1" :: String)) `shouldBe` StreamName "orders-o-1" + + it "rejects blank entity stream id segments" $ do + let cat = Stream.categoryUnsafe "orders" :: Stream.StreamCategory OrderStream + evaluate (Stream.streamName (Stream.entityStream cat "")) `shouldThrow` anyErrorCall + evaluate (Stream.streamName (Stream.entityStream cat " ")) `shouldThrow` anyErrorCall + + describe "Keiro.DeadLetter" $ around (withFreshStore fixture) $ do + it "records a dispatch dead letter idempotently" $ \storeHandle -> do + let deadLetter = + DispatchDeadLetter + { dispatcherKind = DispatcherProcessManager + , dispatcherName = "orders-pm" + , correlationId = "order-42" + , sourceEventId = EventId sampleUuid + , sourceGlobalPosition = GlobalPosition 17 + , emitIndex = 0 + , targetStreamName = StreamName "orders-42" + , errorClass = "command_rejected" + , errorDetail = Text.replicate 1100 "x" + , attemptCount = 2 + } + Right rows <- + Store.runStoreIO storeHandle $ do + recordDispatchDeadLetter deadLetter + recordDispatchDeadLetter deadLetter + listDispatchDeadLetters "orders-pm" + case rows of + [row] -> do + row ^. #dispatcherKind `shouldBe` DispatcherProcessManager + row ^. #dispatcherName `shouldBe` "orders-pm" + row ^. #correlationId `shouldBe` "order-42" + row ^. #sourceEventId `shouldBe` EventId sampleUuid + row ^. #sourceGlobalPosition `shouldBe` GlobalPosition 17 + row ^. #emitIndex `shouldBe` 0 + row ^. #targetStreamName `shouldBe` StreamName "orders-42" + row ^. #errorClass `shouldBe` "command_rejected" + Text.length (row ^. #errorDetail) `shouldBe` 1024 + row ^. #attemptCount `shouldBe` 2 + other -> expectationFailure ("expected one idempotent dead-letter row, got " <> show other) + + describe "Keiro.Codec" $ do + it "encodes current events with type tags and schema-version metadata" $ do + encoded <- shouldBeRight (encodeForAppend orderCodec (OrderPlaced "order-123" 5)) + encoded ^. #eventType `shouldBe` EventType "OrderPlaced" + encoded ^. #payload `shouldBe` object ["orderId" Aeson..= ("order-123" :: Text), "quantity" Aeson..= (5 :: Int)] + extractSchemaVersion (recordedFrom encoded) `shouldBe` Right 2 + + it "round-trips current events" $ do + encoded <- shouldBeRight (encodeForAppend orderCodec (OrderPlaced "order-123" 5)) + decodeRecorded orderCodec (recordedFrom encoded) `shouldBe` Right (OrderPlaced "order-123" 5) + + it "decodes by the stored tag, not by payload shape (H1)" $ do + let recorded = + recordedFrom + EventData + { eventId = Nothing + , eventType = EventType "CounterAudited" + , payload = object ["amount" Aeson..= (5 :: Int)] + , metadata = Just (metadataForOrDie 1 Nothing) + , causationId = Nothing + , correlationId = Nothing + } + decodeRecorded counterCodec recorded `shouldBe` Right (CounterAudited 5) + + it "runs upcasters in source-version order" $ + decodeRaw orderCodec (EventType "OrderPlaced") 1 (object ["orderId" Aeson..= ("order-123" :: Text), "qty" Aeson..= (5 :: Int)]) + `shouldBe` Right (OrderPlaced "order-123" 5) + + it "rejects gaps in upcaster chains" $ + decodeRaw gappyCodec (EventType "OrderPlaced") 1 (object ["orderId" Aeson..= ("order-123" :: Text), "qty" Aeson..= (5 :: Int)]) + `shouldBe` Left (GapInUpcasterChain 2 3) + + it "validates codec construction invariants" $ do + fmap (const ()) (mkCodec (orderCodec{schemaVersion = 0})) `shouldBe` Left (CodecSchemaVersionInvalid 0) + fmap (const ()) (mkCodec (orderCodec{eventTypes = EventType "OrderPlaced" :| [EventType "OrderPlaced"]})) + `shouldBe` Left (CodecDuplicateEventTypes [EventType "OrderPlaced"]) + fmap (const ()) (mkCodec (orderCodec{schemaVersion = 3, upcasters = [(1, const upcastOrderPlacedV1), (1, const upcastOrderPlacedV1)]})) + `shouldBe` Left (CodecDuplicateUpcasterSources [1]) + fmap (const ()) (mkCodec (orderCodec{schemaVersion = 3, upcasters = [(1, const upcastOrderPlacedV1)]})) + `shouldBe` Left (CodecUpcasterChainIncomplete [2] 3) + case mkCodec orderCodec of + Right _ -> pure () + Left err -> expectationFailure ("expected orderCodec to validate, got " <> show err) + + it "rejects future-version, malformed metadata, and incomplete upcaster chains" $ do + let v1Payload = object ["orderId" Aeson..= ("order-123" :: Text), "qty" Aeson..= (5 :: Int)] + earlyEndCodec = + orderCodec + { schemaVersion = 4 + , upcasters = [(1, const upcastOrderPlacedV1), (2, const Right)] + } + decodeRaw orderCodec (EventType "OrderPlaced") 3 v1Payload + `shouldBe` Left (VersionAhead 3 2) + decodeRaw earlyEndCodec (EventType "OrderPlaced") 1 v1Payload + `shouldBe` Left (IncompleteUpcasterChain 3 4) + + let malformedStamp = + recordedFrom + EventData + { eventId = Nothing + , eventType = EventType "OrderPlaced" + , payload = object ["orderId" Aeson..= ("order-123" :: Text), "quantity" Aeson..= (5 :: Int)] + , metadata = Just (object ["schemaVersion" Aeson..= ("2" :: Text)]) + , causationId = Nothing + , correlationId = Nothing + } + extractSchemaVersion malformedStamp + `shouldBe` Left (MalformedSchemaVersionStamp (Aeson.String "2")) + fmap (const ()) (encodeForAppendWithMetadata orderCodec (Just (Aeson.String "x")) (OrderPlaced "order-123" 5)) + `shouldBe` Left (NonObjectCallerMetadata (Aeson.String "x")) + + it "rejects recorded events with unknown type tags" $ do + let encoded = + recordedFrom + EventData + { eventId = Nothing + , eventType = EventType "OrderCancelled" + , payload = object ["orderId" Aeson..= ("order-123" :: Text)] + , metadata = Just (metadataForOrDie 2 Nothing) + , causationId = Nothing + , correlationId = Nothing + } + decodeRecorded orderCodec encoded + `shouldBe` Left (UnknownEventType (EventType "OrderCancelled") [EventType "OrderPlaced"]) + + describe "Keiro.EventStream" $ do + it "constructs an author-facing EventStream contract" $ do + let contract = + EventStream + { transducer = emptyTransducer + , initialState = Idle + , initialRegisters = RNil + , eventCodec = orderCodec + , resolveStreamName = \s -> Stream.streamName s + , snapshotPolicy = Never + , stateCodec = Nothing + } + typedStream = stream "order-123" :: Stream (EventStream () '[] OrderState OrderCommand OrderEvent) + contract ^. #initialState `shouldBe` Idle + (contract ^. #resolveStreamName) typedStream `shouldBe` StreamName "order-123" + + it "evaluates snapshot policies with explicit terminality" $ do + shouldSnapshot (Every 2) NotTerminal () (StreamVersion 0) `shouldBe` False + shouldSnapshot (Every 2) NotTerminal () (StreamVersion 2) `shouldBe` True + shouldSnapshot OnTerminal Terminal () (StreamVersion 1) `shouldBe` True + shouldSnapshot OnTerminal NotTerminal () (StreamVersion 1) `shouldBe` False + shouldSnapshot (Custom (\terminality _ _ -> terminality == Terminal)) Terminal () (StreamVersion 1) + `shouldBe` True + shouldSnapshot (Custom (\terminality _ _ -> terminality == Terminal)) NotTerminal () (StreamVersion 1) + `shouldBe` False + shouldSnapshotSpan (Every 3) NotTerminal () (StreamVersion 2) (StreamVersion 4) + `shouldBe` True + shouldSnapshotSpan (Every 3) NotTerminal () (StreamVersion 4) (StreamVersion 5) + `shouldBe` False + + it "rejects snapshot policies without a state codec" $ do + let contract :: CounterEventStream + contract = counterEventStreamDef{snapshotPolicy = Every 10, stateCodec = Nothing} + fmap (const ()) (mkEventStream "snapshotless" contract) + `shouldBe` Left [EventStreamWarning "snapshotless" "snapshotPolicy is set but stateCodec is Nothing; snapshots would never be written"] + + describe "EventStream replay-safety (validateEventStream)" $ do + it "every production-intent stream validates clean" $ + concat + [ validateEventStream "counter" counterEventStreamDef + , validateEventStream "counter-no-op" noOpCounterEventStreamDef + , validateEventStream "counter-multi" multiCounterEventStreamDef + , validateEventStream "counter-ambiguous" ambiguousCounterEventStreamDef + , validateEventStream "snapshot-counter" snapshotCounterEventStreamDef + , validateEventStream "snapshot-counter-multi" multiSnapshotCounterEventStreamDef + , validateEventStream "snapshot-counter-guarded" guardedSnapshotCounterEventStreamDef + , validateEventStream "pm-snapshot-counter" pmSnapshotCounterEventStreamDef + , validateEventStream "rejecting-counter" rejectingEventStreamDef + ] + `shouldBe` [] + + describe "mkEventStream" $ do + it "rejects a hidden-input stream by label" $ do + let warns = validateEventStream "broken" brokenHiddenInputEventStream + warns `shouldNotBe` [] + map eswStreamLabel warns `shouldSatisfy` all (== "broken") + map eswReason warns `shouldSatisfy` any (Text.isInfixOf "hidden-input") + case mkEventStream "broken" brokenHiddenInputEventStream of + Left ws -> do + map eswStreamLabel ws `shouldSatisfy` all (== "broken") + map eswReason ws `shouldSatisfy` any (Text.isInfixOf "hidden-input") + Right _ -> expectationFailure "expected mkEventStream to reject the hidden-input stream" + + it "rejects a head-unrecoverable multi-event stream" $ + expectValidationWarning + "head-unrecoverable" + "head-unrecoverable" + headUnrecoverableEventStreamDef + + it "rejects replay inversion ambiguity" $ + expectValidationWarning + "inversion-ambiguity" + "inversion-ambiguity" + inversionAmbiguousEventStreamDef + + it "rejects an unguarded command-field read" $ + expectValidationWarning + "unguarded-input-read" + "unguarded-input-read" + unguardedInputReadEventStreamDef + + it "rejects a silent edge that writes registers" $ do + Keiki.validateTransducer Keiki.defaultValidationOptions stateChangingEpsilonTransducer + `shouldSatisfy` any isStateChangingEpsilon + expectValidationWarning + "state-changing-epsilon" + "state-changing-epsilon" + stateChangingEpsilonEventStreamDef + + it "rejects a silent edge that changes vertex" $ do + Keiki.validateTransducer Keiki.defaultValidationOptions silentMoveTransducer + `shouldSatisfy` any isStateChangingEpsilon + expectValidationWarning + "silent-move" + "state-changing-epsilon" + silentMoveEventStreamDef + + it "keeps replay-contract checks enabled when caller options weaken them" $ do + case mkEventStreamWith + Keiki.defaultValidationOptions{Keiki.checkStateChangingEpsilon = False} + "silent-move-weakened" + silentMoveEventStreamDef of + Left warnings -> + map eswReason warnings + `shouldSatisfy` any (Text.isInfixOf "state-changing-epsilon") + Right _ -> expectationFailure "expected the durable boundary to restore the state-changing-epsilon check" + case mkEventStreamWith + Keiki.defaultValidationOptions{Keiki.checkHeadRecoverability = False} + "head-unrecoverable-weakened" + headUnrecoverableEventStreamDef of + Left warnings -> + map eswReason warnings + `shouldSatisfy` any (Text.isInfixOf "head-unrecoverable") + Right _ -> expectationFailure "expected the durable boundary to restore the head-recoverability check" + + it "provides a loudly named unchecked escape hatch" $ do + _ <- evaluate (mkEventStreamUnchecked silentMoveEventStreamDef) + pure () + + it "accepts every production-intent stream" $ do + let expectAccepted label eventStream = + case mkEventStream label eventStream of + Right _ -> pure () + Left ws -> expectationFailure ("expected mkEventStream to accept " <> Text.unpack label <> ", got " <> show ws) + expectAccepted "counter" counterEventStreamDef + expectAccepted "counter-no-op" noOpCounterEventStreamDef + expectAccepted "counter-multi" multiCounterEventStreamDef + expectAccepted "counter-ambiguous" ambiguousCounterEventStreamDef + expectAccepted "snapshot-counter" snapshotCounterEventStreamDef + expectAccepted "snapshot-counter-multi" multiSnapshotCounterEventStreamDef + expectAccepted "snapshot-counter-guarded" guardedSnapshotCounterEventStreamDef + expectAccepted "pm-snapshot-counter" pmSnapshotCounterEventStreamDef + expectAccepted "rejecting-counter" rejectingEventStreamDef + + it "rejects a snapshot codec whose initial register file contains an uninitialized slot" $ do + case mkEventStream "uninitialized-snapshot" uninitializedSnapshotEventStreamDef of + Left warns -> do + map eswStreamLabel warns `shouldSatisfy` all (== "uninitialized-snapshot") + map eswReason warns `shouldSatisfy` any (Text.isInfixOf "cannot encode the initial state/registers") + map eswReason warns `shouldSatisfy` any (Text.isInfixOf "uninit: neverWritten") + Right _ -> expectationFailure "expected mkEventStream to reject an uninitialized snapshot register" + + it "accepts the same snapshot stream when every initial register is initialized" $ do + case mkEventStream "initialized-snapshot" initializedSnapshotEventStreamDef of + Right _ -> pure () + Left warns -> expectationFailure ("expected initialized snapshot registers to validate, got " <> show warns) + + it "rejects a bare EventStream at runCommand (compile-time)" $ do + (exitCode, _stdout, stderr) <- + readProcessWithExitCode + "cabal" + [ "exec" + , "ghc" + , "--" + , "-fno-code" + , "-package" + , "keiro" + , "test/ReplaySafetyTypeProbe.hs" + ] + "" + exitCode `shouldSatisfy` (/= ExitSuccess) + stderr `shouldSatisfy` ("ValidatedEventStream" `isInfixOf`) + + describe "Keiro.Command" $ around (withFreshStore fixture) $ do + it "creates a stream and appends the first command event" $ \storeHandle -> do + let target = stream "counter-command-create" :: Stream CounterEventStream + result <- + Store.runStoreIO storeHandle $ + runCommand defaultRunCommandOptions counterEventStream target (Add 2) + case result of + Right (Right commandResult) -> do + commandResult ^. #streamVersion `shouldBe` StreamVersion 1 + commandResult ^. #eventsAppended `shouldBe` 1 + commandResult ^. #globalPosition `shouldSatisfy` isJust + other -> expectationFailure ("expected successful command, got " <> show other) + Right recorded <- + Store.runStoreIO storeHandle $ + Store.readStreamForward (StreamName "counter-command-create") (StreamVersion 0) 10 + Vector.length recorded `shouldBe` 1 + traverse (decodeRecorded counterCodec) (Vector.toList recorded) + `shouldBe` Right [CounterAdded 2] + + it "reports no global position for a no-op after prior events" $ \storeHandle -> do + let target = stream "skip-command-no-op-position" :: Stream SkipEventStream + Right (Right appended) <- + Store.runStoreIO storeHandle $ + runCommand defaultRunCommandOptions skipEventStream target (SAdd 2) + appended ^. #globalPosition `shouldSatisfy` isJust + result <- + Store.runStoreIO storeHandle $ + runCommand defaultRunCommandOptions skipEventStream target SSkip + case result of + Right (Right noOp) -> do + noOp ^. #streamVersion `shouldBe` StreamVersion 1 + noOp ^. #eventsAppended `shouldBe` 0 + noOp ^. #globalPosition `shouldBe` Nothing + other -> expectationFailure ("expected successful no-op command, got " <> show other) + + it "surfaces runtime edge ambiguity without appending" $ \storeHandle -> do + (processor, spansRef) <- inMemoryListExporter + provider <- createTracerProvider [processor] emptyTracerProviderOptions + let tracer = makeTracer provider "keiro-test" tracerOptions + target = stream "counter-command-ambiguous" :: Stream CounterEventStream + options = defaultRunCommandOptions & #tracer ?~ tracer + result <- + Store.runStoreIO storeHandle $ + runCommand options ambiguousCounterEventStream target (Add 1) + _ <- shutdownTracerProvider provider Nothing + result `shouldBe` Right (Left (CommandAmbiguous [0, 1])) + Right recorded <- + Store.runStoreIO storeHandle $ + Store.readStreamForward (StreamName "counter-command-ambiguous") (StreamVersion 0) 10 + recorded `shouldBe` Vector.empty + spans <- traverse captureSpan =<< readIORef spansRef + case spans of + [sp] -> textAttr (csAttributes sp) "error.type" `shouldBe` Just "command_ambiguous" + other -> expectationFailure ("expected one span, got " <> show (length other)) + + it "rehydrates prior events before appending a second command event" $ \storeHandle -> do + let target = stream "counter-command-update" :: Stream CounterEventStream + Right (Right _) <- + Store.runStoreIO storeHandle $ + runCommand defaultRunCommandOptions counterEventStream target (Add 2) + result <- + Store.runStoreIO storeHandle $ + runCommand defaultRunCommandOptions counterEventStream target (Add 3) + case result of + Right (Right commandResult) -> + commandResult ^. #streamVersion `shouldBe` StreamVersion 2 + other -> expectationFailure ("expected successful second command, got " <> show other) + Right recorded <- + Store.runStoreIO storeHandle $ + Store.readStreamForward (StreamName "counter-command-update") (StreamVersion 0) 10 + traverse (decodeRecorded counterCodec) (Vector.toList recorded) + `shouldBe` Right [CounterAdded 2, CounterAdded 3] + + it "rejects hydration after truncation without a covering snapshot" $ \storeHandle -> do + let target = stream "counter-truncated-uncovered" :: Stream CounterEventStream + targetName = StreamName "counter-truncated-uncovered" + Right (Right _) <- + Store.runStoreIO storeHandle $ + runCommand defaultRunCommandOptions counterEventStream target (Add 1) + Right (Right _) <- + Store.runStoreIO storeHandle $ + runCommand defaultRunCommandOptions counterEventStream target (Add 2) + Right (Right _) <- + Store.runStoreIO storeHandle $ + runCommand defaultRunCommandOptions counterEventStream target (Add 3) + Right (Just _) <- + Store.runStoreIO storeHandle $ + Store.setStreamTruncateBefore targetName (StreamVersion 3) + result <- + Store.runStoreIO storeHandle $ + runCommand defaultRunCommandOptions counterEventStream target (Add 4) + case result of + Right (Left (HydrationGapDetected expected observed)) -> do + expected `shouldBe` StreamVersion 1 + observed `shouldBe` StreamVersion 3 + other -> expectationFailure ("expected HydrationGapDetected, got " <> show other) + + it "rejects hydration when truncation lands inside a command batch" $ \storeHandle -> do + let target = stream "counter-truncated-mid-batch" :: Stream CounterEventStream + targetName = StreamName "counter-truncated-mid-batch" + Right (Right _) <- + Store.runStoreIO storeHandle $ + runCommand defaultRunCommandOptions multiCounterEventStream target (Add 1) + Right (Just _) <- + Store.runStoreIO storeHandle $ + Store.setStreamTruncateBefore targetName (StreamVersion 2) + result <- + Store.runStoreIO storeHandle $ + runCommand defaultRunCommandOptions multiCounterEventStream target (Add 2) + case result of + Right (Left (HydrationGapDetected expected observed)) -> do + expected `shouldBe` StreamVersion 1 + observed `shouldBe` StreamVersion 2 + other -> expectationFailure ("expected HydrationGapDetected, got " <> show other) + + it "hydrates normally after truncation covered by a snapshot" $ \storeHandle -> do + let target = stream "counter-truncated-covered" :: Stream SnapshotCounterEventStream + targetName = StreamName "counter-truncated-covered" + Right (Right _) <- + Store.runStoreIO storeHandle $ + runCommand defaultRunCommandOptions snapshotCounterEventStream target (Add 1) + Right (Right _) <- + Store.runStoreIO storeHandle $ + runCommand defaultRunCommandOptions snapshotCounterEventStream target (Add 2) + Right (Just _) <- + Store.runStoreIO storeHandle $ + Store.setStreamTruncateBefore targetName (StreamVersion 2) + result <- + Store.runStoreIO storeHandle $ + runCommand defaultRunCommandOptions snapshotCounterEventStream target (Add 3) + case result of + Right (Right commandResult) -> + commandResult ^. #streamVersion `shouldBe` StreamVersion 3 + other -> expectationFailure ("expected snapshot-covered command success, got " <> show other) + + it "uses caller-supplied event ids for idempotent command batches" $ \storeHandle -> do + let target = stream "counter-command-event-id" :: Stream CounterEventStream + supplied = EventId sampleUuid2 + options = defaultRunCommandOptions & #eventIds .~ [supplied] + result <- + Store.runStoreIO storeHandle $ + runCommand options counterEventStream target (Add 7) + case result of + Right (Right commandResult) -> + commandResult ^. #streamVersion `shouldBe` StreamVersion 1 + other -> expectationFailure ("expected successful command, got " <> show other) + Right recorded <- + Store.runStoreIO storeHandle $ + Store.readStreamForward (StreamName "counter-command-event-id") (StreamVersion 0) 10 + fmap (^. #eventId) (Vector.toList recorded) `shouldBe` [supplied] + + it "retries an optimistic conflict after rehydrating the winning event" $ \storeHandle -> do + conflictInserted <- newIORef False + let target = stream "counter-command-conflict" :: Stream CounterEventStream + conflictStreamName = StreamName "counter-command-conflict" + insertConflict = do + shouldInsert <- atomicModifyIORef' conflictInserted $ \alreadyInserted -> + if alreadyInserted + then (True, False) + else (True, True) + when shouldInsert $ do + encoded <- shouldBeRight (encodeForAppend counterCodec (CounterAdded 10)) + outcome <- + Store.runStoreIO storeHandle $ + Store.appendToStream conflictStreamName NoStream [encoded] + case outcome of + Right _ -> pure () + Left err -> expectationFailure ("failed to insert conflict event: " <> show err) + options = defaultRunCommandOptions & #beforeAppend .~ insertConflict + result <- + Store.runStoreIO storeHandle $ + runCommand options counterEventStream target (Add 2) + case result of + Right (Right commandResult) -> do + commandResult ^. #streamVersion `shouldBe` StreamVersion 2 + commandResult ^. #eventsAppended `shouldBe` 1 + other -> expectationFailure ("expected retry to succeed, got " <> show other) + Right recorded <- + Store.runStoreIO storeHandle $ + Store.readStreamForward conflictStreamName (StreamVersion 0) 10 + traverse (decodeRecorded counterCodec) (Vector.toList recorded) + `shouldBe` Right [CounterAdded 10, CounterAdded 2] + + it "reports true retry attempts and command conflict metrics when the retry budget is exhausted" $ \storeHandle -> do + (exporter, metricsRef) <- inMemoryMetricExporter + (provider, _env) <- + createMeterProvider + emptyMaterializedResources + defaultSdkMeterProviderOptions{metricExporter = Just exporter} + meter <- getMeter provider Telemetry.keiroInstrumentationLibrary + keiroMetrics <- Telemetry.newKeiroMetrics meter + let target = stream "counter-command-exhausted-conflict" :: Stream CounterEventStream + conflictStreamName = StreamName "counter-command-exhausted-conflict" + insertConflict = do + encoded <- shouldBeRight (encodeForAppend counterCodec (CounterAdded 10)) + outcome <- + Store.runStoreIO storeHandle $ + Store.appendToStream conflictStreamName AnyVersion [encoded] + case outcome of + Right _ -> pure () + Left err -> expectationFailure ("failed to insert conflict event: " <> show err) + options = + defaultRunCommandOptions + & #beforeAppend + .~ insertConflict + & #retryLimit + .~ 2 + & #retryBackoffMicros + .~ 0 + & #metrics + ?~ keiroMetrics + result <- + Store.runStoreIO storeHandle $ + runCommand options counterEventStream target (Add 2) + case result of + Right (Left (RetryExhausted attempts _)) -> + attempts `shouldBe` 3 + other -> expectationFailure ("expected exhausted retry budget, got " <> show other) + _ <- forceFlushMeterProvider provider Nothing + exported <- readIORef metricsRef + let scalars = flattenScalarPoints exported + lookup "keiro.command.conflicts" scalars `shouldBe` Just (IntNumber 3) + lookup "keiro.command.retries" scalars `shouldBe` Just (IntNumber 2) + + it "records the successful retry attempt on the command span" $ \storeHandle -> do + (processor, spansRef) <- inMemoryListExporter + provider <- createTracerProvider [processor] emptyTracerProviderOptions + conflictInserted <- newIORef False + let tracer = makeTracer provider "keiro-test" tracerOptions + target = stream "counter-command-retry-span" :: Stream CounterEventStream + conflictStreamName = StreamName "counter-command-retry-span" + insertConflict = do + shouldInsert <- atomicModifyIORef' conflictInserted $ \alreadyInserted -> + if alreadyInserted + then (True, False) + else (True, True) + when shouldInsert $ do + encoded <- shouldBeRight (encodeForAppend counterCodec (CounterAdded 10)) + outcome <- + Store.runStoreIO storeHandle $ + Store.appendToStream conflictStreamName NoStream [encoded] + case outcome of + Right _ -> pure () + Left err -> expectationFailure ("failed to insert conflict event: " <> show err) + options = + defaultRunCommandOptions + & #beforeAppend + .~ insertConflict + & #retryBackoffMicros + .~ 0 + & #tracer + ?~ tracer + Right (Right _) <- + Store.runStoreIO storeHandle $ + runCommand options counterEventStream target (Add 2) + _ <- shutdownTracerProvider provider Nothing + spans <- traverse captureSpan =<< readIORef spansRef + case spans of + [sp] -> + case lookupAttribute (csAttributes sp) "keiro.retry.attempt" of + Just (AttributeValue (IntAttribute n)) -> n `shouldBe` 2 + other -> expectationFailure ("expected retry attempt attribute 2, got " <> show other) + other -> expectationFailure ("expected one span, got " <> show (length other)) + + it "counts duplicate deterministic command events" $ \storeHandle -> do + (exporter, metricsRef) <- inMemoryMetricExporter + (provider, _env) <- + createMeterProvider + emptyMaterializedResources + defaultSdkMeterProviderOptions{metricExporter = Just exporter} + meter <- getMeter provider Telemetry.keiroInstrumentationLibrary + keiroMetrics <- Telemetry.newKeiroMetrics meter + let supplied = EventId sampleUuid3 + first = stream "counter-command-duplicate-a" :: Stream CounterEventStream + second = stream "counter-command-duplicate-b" :: Stream CounterEventStream + options = + defaultRunCommandOptions + & #eventIds + .~ [supplied] + & #metrics + ?~ keiroMetrics + Right (Right _) <- + Store.runStoreIO storeHandle $ + runCommand options counterEventStream first (Add 1) + result <- + Store.runStoreIO storeHandle $ + runCommand options counterEventStream second (Add 2) + case result of + Right (Left (StoreFailed Store.DuplicateEvent{})) -> pure () + other -> expectationFailure ("expected duplicate event failure, got " <> show other) + _ <- forceFlushMeterProvider provider Nothing + exported <- readIORef metricsRef + lookup "keiro.command.duplicates" (flattenScalarPoints exported) `shouldBe` Just (IntNumber 1) + + it "fails fast when a soft-deleted stream causes a conflict fixpoint" $ \storeHandle -> do + (exporter, metricsRef) <- inMemoryMetricExporter + (provider, _env) <- + createMeterProvider + emptyMaterializedResources + defaultSdkMeterProviderOptions{metricExporter = Just exporter} + meter <- getMeter provider Telemetry.keiroInstrumentationLibrary + keiroMetrics <- Telemetry.newKeiroMetrics meter + let target = stream "counter-command-soft-deleted" :: Stream CounterEventStream + options = + defaultRunCommandOptions + & #retryBackoffMicros + .~ 0 + & #metrics + ?~ keiroMetrics + Right (Right _) <- + Store.runStoreIO storeHandle $ + runCommand options counterEventStream target (Add 1) + Right (Just _) <- + Store.runStoreIO storeHandle $ + Store.softDeleteStream (StreamName "counter-command-soft-deleted") + result <- + Store.runStoreIO storeHandle $ + runCommand options counterEventStream target (Add 2) + case result of + Right (Left (ConflictFixpoint (StreamVersion 0) Store.StreamAlreadyExists{})) -> pure () + other -> expectationFailure ("expected conflict fixpoint, got " <> show other) + _ <- forceFlushMeterProvider provider Nothing + exported <- readIORef metricsRef + lookup "keiro.command.conflicts" (flattenScalarPoints exported) `shouldBe` Just (IntNumber 1) + + it "surfaces decode failure during hydration" $ \storeHandle -> do + Right _ <- + Store.runStoreIO storeHandle $ + Store.appendToStream + (StreamName "counter-command-decode-failure") + NoStream + [ EventData + { eventId = Nothing + , eventType = EventType "OtherEvent" + , payload = object [] + , metadata = Just (metadataForOrDie 1 Nothing) + , causationId = Nothing + , correlationId = Nothing + } + ] + let target = stream "counter-command-decode-failure" :: Stream CounterEventStream + result <- + Store.runStoreIO storeHandle $ + runCommand defaultRunCommandOptions counterEventStream target (Add 1) + result + `shouldBe` Right + (Left (HydrationDecodeFailed (UnknownEventType (EventType "OtherEvent") [EventType "CounterAdded", EventType "CounterAudited"]))) + + it "surfaces a typed no-inverting-edge hydration failure" $ \storeHandle -> do + let targetStreamName = StreamName "counter-command-no-inverting-edge" + target = stream "counter-command-no-inverting-edge" :: Stream CounterEventStream + appendCounterEvents storeHandle targetStreamName [CounterAudited 7] + result <- + Store.runStoreIO storeHandle $ + runCommand defaultRunCommandOptions counterEventStream target (Add 1) + result + `shouldBe` Right + (Left (HydrationReplayFailed (StreamVersion 1) HydrationNoInvertingEdge)) + + it "surfaces a typed queue-mismatch hydration failure with the failing version" $ \storeHandle -> do + let targetStreamName = StreamName "counter-command-queue-mismatch" + target = stream "counter-command-queue-mismatch" :: Stream CounterEventStream + appendCounterEvents storeHandle targetStreamName [CounterAdded 5, CounterAudited 6] + result <- + Store.runStoreIO storeHandle $ + runCommand defaultRunCommandOptions multiCounterEventStream target (Add 1) + result + `shouldBe` Right + (Left (HydrationReplayFailed (StreamVersion 2) HydrationQueueMismatch)) + + it "surfaces a truncated multi-event chain as HydrationTruncatedChain" $ \storeHandle -> do + let targetStreamName = StreamName "counter-command-truncated-chain" + target = stream "counter-command-truncated-chain" :: Stream CounterEventStream + appendCounterEvents storeHandle targetStreamName [CounterAdded 5] + result <- + Store.runStoreIO storeHandle $ + runCommand defaultRunCommandOptions multiCounterEventStream target (Add 1) + result + `shouldBe` Right + (Left (HydrationReplayFailed (StreamVersion 1) HydrationTruncatedChain)) + + it "surfaces ambiguous inversion during hydration" $ \storeHandle -> do + let targetStreamName = StreamName "counter-command-ambiguous-inversion" + target = stream "counter-command-ambiguous-inversion" :: Stream CounterEventStream + appendCounterEvents storeHandle targetStreamName [CounterAdded 3] + result <- + Store.runStoreIO storeHandle $ + runCommand defaultRunCommandOptions inversionAmbiguousEventStream target (Add 1) + result + `shouldBe` Right + (Left (HydrationReplayFailed (StreamVersion 1) HydrationAmbiguousInversion)) + + it "truncates command span error status descriptions" $ \storeHandle -> do + (processor, spansRef) <- inMemoryListExporter + provider <- createTracerProvider [processor] emptyTracerProviderOptions + let tracer = makeTracer provider "keiro-test" tracerOptions + longTag = Text.replicate 400 "x" + Right _ <- + Store.runStoreIO storeHandle $ + Store.appendToStream + (StreamName "counter-command-long-decode-failure") + NoStream + [ EventData + { eventId = Nothing + , eventType = EventType longTag + , payload = object [] + , metadata = Just (metadataForOrDie 1 Nothing) + , causationId = Nothing + , correlationId = Nothing + } + ] + let target = stream "counter-command-long-decode-failure" :: Stream CounterEventStream + options = defaultRunCommandOptions & #tracer ?~ tracer + _ <- + Store.runStoreIO storeHandle $ + runCommand options counterEventStream target (Add 1) + _ <- shutdownTracerProvider provider Nothing + spans <- traverse captureSpan =<< readIORef spansRef + case spans of + [sp] -> + case csStatus sp of + Error description -> Text.length description `shouldSatisfy` (<= 256) + other -> expectationFailure ("expected error span status, got " <> show other) + other -> expectationFailure ("expected one span, got " <> show (length other)) + + it "rolls back the append when inline SQL condemns the transaction" $ \_ -> + withFreshResourceStore fixture $ \(storeHandle, StoreRunner runner) -> do + let target = stream "counter-command-rollback" :: Stream CounterEventStream + result <- + runner $ + runCommandWithSql + defaultRunCommandOptions + counterEventStream + target + (Add 1) + (\_ -> Tx.condemn >> pure ("rolled-back" :: Text)) + case result of + Right (Right (_, Just "rolled-back")) -> pure () + other -> expectationFailure ("expected condemned transaction result, got " <> show other) + Right recorded <- + Store.runStoreIO storeHandle $ + Store.readStreamForward (StreamName "counter-command-rollback") (StreamVersion 0) 10 + recorded `shouldBe` Vector.empty + + it "appends all events emitted by one accepted command" $ \storeHandle -> do + let target = stream "counter-command-multi-create" :: Stream CounterEventStream + result <- + Store.runStoreIO storeHandle $ + runCommand defaultRunCommandOptions multiCounterEventStream target (Add 5) + case result of + Right (Right commandResult) -> do + commandResult ^. #streamVersion `shouldBe` StreamVersion 2 + commandResult ^. #eventsAppended `shouldBe` 2 + commandResult ^. #globalPosition `shouldSatisfy` isJust + other -> expectationFailure ("expected successful multi-event command, got " <> show other) + Right recorded <- + Store.runStoreIO storeHandle $ + Store.readStreamForward (StreamName "counter-command-multi-create") (StreamVersion 0) 10 + traverse (decodeRecorded counterCodec) (Vector.toList recorded) + `shouldBe` Right [CounterAdded 5, CounterAudited 5] + + it "counts and traces a just-appended batch that cannot replay" $ \storeHandle -> do + (exporter, metricsRef) <- inMemoryMetricExporter + (metricProvider, _env) <- + createMeterProvider + emptyMaterializedResources + defaultSdkMeterProviderOptions{metricExporter = Just exporter} + meter <- getMeter metricProvider Telemetry.keiroInstrumentationLibrary + keiroMetrics <- Telemetry.newKeiroMetrics meter + (processor, spansRef) <- inMemoryListExporter + tracerProvider <- createTracerProvider [processor] emptyTracerProviderOptions + let tracer = makeTracer tracerProvider "keiro-test" tracerOptions + target = stream "counter-command-replay-divergence" :: Stream CounterEventStream + options = + defaultRunCommandOptions + & #metrics + ?~ keiroMetrics + & #tracer + ?~ tracer + Right (Right commandResult) <- + Store.runStoreIO storeHandle $ + runCommand options headUnrecoverableEventStream target (Add 2) + commandResult ^. #streamVersion `shouldBe` StreamVersion 2 + commandResult ^. #eventsAppended `shouldBe` 2 + _ <- forceFlushMeterProvider metricProvider Nothing + exported <- readIORef metricsRef + lookup "keiro.snapshot.apply.divergence" (flattenScalarPoints exported) + `shouldBe` Just (IntNumber 1) + next <- + Store.runStoreIO storeHandle $ + runCommand defaultRunCommandOptions headUnrecoverableEventStream target (Add 3) + case next of + Right (Left HydrationReplayFailed{}) -> pure () + other -> expectationFailure ("expected the witnessed divergence to poison hydration, got " <> show other) + _ <- shutdownTracerProvider tracerProvider Nothing + spans <- traverse captureSpan =<< readIORef spansRef + case spans of + [sp] -> + textAttr (csAttributes sp) "keiro.replay.divergence" + `shouldBe` Just "event_index=0;reason=no_inverting_edge" + other -> expectationFailure ("expected one divergence span, got " <> show (length other)) + + it "skips replay verification for a snapshot-less stream when disabled" $ \storeHandle -> do + (exporter, metricsRef) <- inMemoryMetricExporter + (provider, _env) <- + createMeterProvider + emptyMaterializedResources + defaultSdkMeterProviderOptions{metricExporter = Just exporter} + meter <- getMeter provider Telemetry.keiroInstrumentationLibrary + keiroMetrics <- Telemetry.newKeiroMetrics meter + let target = stream "counter-command-replay-divergence-disabled" :: Stream CounterEventStream + options = + defaultRunCommandOptions + & #metrics + ?~ keiroMetrics + & #verifyReplayOnAppend + .~ False + Right (Right commandResult) <- + Store.runStoreIO storeHandle $ + runCommand options headUnrecoverableEventStream target (Add 2) + commandResult ^. #eventsAppended `shouldBe` 2 + _ <- forceFlushMeterProvider provider Nothing + exported <- readIORef metricsRef + lookup "keiro.snapshot.apply.divergence" (flattenScalarPoints exported) + `shouldBe` Nothing + + it "witnesses replay divergence on the transactional SQL append path" $ \_ -> + withFreshResourceStore fixture $ \(_storeHandle, StoreRunner runner) -> do + (exporter, metricsRef) <- inMemoryMetricExporter + (provider, _env) <- + createMeterProvider + emptyMaterializedResources + defaultSdkMeterProviderOptions{metricExporter = Just exporter} + meter <- getMeter provider Telemetry.keiroInstrumentationLibrary + keiroMetrics <- Telemetry.newKeiroMetrics meter + let target = stream "counter-command-replay-divergence-sql" :: Stream CounterEventStream + options = defaultRunCommandOptions & #metrics ?~ keiroMetrics + Right (Right (commandResult, Just ())) <- + runner $ + runCommandWithSqlEvents + options + headUnrecoverableEventStream + target + (Add 2) + (\_ _ -> pure ()) + commandResult ^. #eventsAppended `shouldBe` 2 + _ <- forceFlushMeterProvider provider Nothing + exported <- readIORef metricsRef + lookup "keiro.snapshot.apply.divergence" (flattenScalarPoints exported) + `shouldBe` Just (IntNumber 1) + + it "replays a prior multi-event command before appending the next batch" $ \storeHandle -> do + let target = stream "counter-command-multi-replay" :: Stream CounterEventStream + Right (Right _) <- + Store.runStoreIO storeHandle $ + runCommand defaultRunCommandOptions multiCounterEventStream target (Add 2) + result <- + Store.runStoreIO storeHandle $ + runCommand defaultRunCommandOptions multiCounterEventStream target (Add 3) + case result of + Right (Right commandResult) -> do + commandResult ^. #streamVersion `shouldBe` StreamVersion 4 + commandResult ^. #eventsAppended `shouldBe` 2 + other -> expectationFailure ("expected successful second multi-event command, got " <> show other) + Right recorded <- + Store.runStoreIO storeHandle $ + Store.readStreamForward (StreamName "counter-command-multi-replay") (StreamVersion 0) 10 + traverse (decodeRecorded counterCodec) (Vector.toList recorded) + `shouldBe` Right [CounterAdded 2, CounterAudited 2, CounterAdded 3, CounterAudited 3] + + it "passes the complete multi-event batch to inline SQL in append order" $ \_ -> + withFreshResourceStore fixture $ \(_storeHandle, StoreRunner runner) -> do + let target = stream "counter-command-multi-sql-events" :: Stream CounterEventStream + result <- + runner $ + runCommandWithSqlEvents + defaultRunCommandOptions + multiCounterEventStream + target + (Add 8) + (\pairs _ -> pure (Prelude.map Prelude.fst pairs)) + case result of + Right (Right (commandResult, Just observed)) -> do + commandResult ^. #streamVersion `shouldBe` StreamVersion 2 + commandResult ^. #eventsAppended `shouldBe` 2 + observed `shouldBe` [CounterAdded 8, CounterAudited 8] + other -> expectationFailure ("expected successful SQL multi-event command, got " <> show other) + + it "command metadata is merged into stored event metadata" $ \storeHandle -> do + let target = stream "counter-command-metadata" :: Stream CounterEventStream + opts = + defaultRunCommandOptions + & #metadata + ?~ object ["actor" Aeson..= ("agent-7" :: Text)] + Right (Right _) <- + Store.runStoreIO storeHandle $ + runCommand opts counterEventStream target (Add 4) + Right recorded <- + Store.runStoreIO storeHandle $ + Store.readStreamForward (StreamName "counter-command-metadata") (StreamVersion 0) 10 + case Vector.toList recorded of + [event] -> + event ^. #metadata + `shouldBe` Just (object ["actor" Aeson..= ("agent-7" :: Text), "schemaVersion" Aeson..= (1 :: Int)]) + other -> expectationFailure ("expected a single recorded event, got " <> show other) + + it "reconstructed RecordedEvents match the stored batch" $ \_ -> + withFreshResourceStore fixture $ \(storeHandle, StoreRunner runner) -> do + let target = stream "counter-reconstruct-fidelity" :: Stream CounterEventStream + opts = + defaultRunCommandOptions + & #metadata + ?~ object ["actor" Aeson..= ("agent-7" :: Text)] + Right (Right (_, Just pairs)) <- + runner $ + runCommandWithSqlEvents opts multiCounterEventStream target (Add 8) (\ps _ -> pure ps) + let reconstructed = Prelude.map Prelude.snd pairs + -- Read the stored events back from their source stream. + Right storedVec <- + Store.runStoreIO storeHandle $ + Store.readStreamForward (StreamName "counter-reconstruct-fidelity") (StreamVersion 0) 10 + let stored = Vector.toList storedVec + -- readStreamForward reports globalPosition 0 for stream reads, so take + -- the true global positions from a category read (the DB is fresh per + -- test, so category "counter" holds exactly this batch). + Right catVec <- + Store.runStoreIO storeHandle $ + Store.readCategory (CategoryName "counter") (GlobalPosition 0) 10 + let catList = Vector.toList catVec + Prelude.length reconstructed `shouldBe` 2 + Prelude.length stored `shouldBe` 2 + fmap (^. #eventId) reconstructed `shouldBe` fmap (^. #eventId) stored + fmap (^. #eventType) reconstructed `shouldBe` fmap (^. #eventType) stored + fmap (^. #streamVersion) reconstructed `shouldBe` fmap (^. #streamVersion) stored + fmap (^. #originalVersion) reconstructed `shouldBe` fmap (^. #originalVersion) stored + fmap (^. #originalStreamId) reconstructed `shouldBe` fmap (^. #originalStreamId) stored + fmap (^. #payload) reconstructed `shouldBe` fmap (^. #payload) stored + fmap (^. #metadata) reconstructed `shouldBe` fmap (^. #metadata) stored + fmap (^. #globalPosition) reconstructed `shouldBe` fmap (^. #globalPosition) catList + + it "runCommand emits a Command span with the stream name, db.system.name, and keiro.events.appended" $ \storeHandle -> do + (processor, spansRef) <- inMemoryListExporter + provider <- createTracerProvider [processor] emptyTracerProviderOptions + let tracer = makeTracer provider "keiro-test" tracerOptions + target = stream "counter-command-otel" :: Stream CounterEventStream + options = defaultRunCommandOptions & #tracer ?~ tracer + Right (Right commandResult) <- + Store.runStoreIO storeHandle $ + runCommand options counterEventStream target (Add 9) + commandResult ^. #streamVersion `shouldBe` StreamVersion 1 + _ <- shutdownTracerProvider provider Nothing + spans <- traverse captureSpan =<< readIORef spansRef + length spans `shouldBe` 1 + let sp = case spans of + (s : _) -> s + [] -> error "no command span captured" + csName sp `shouldBe` "counter-command-otel" + show (csKind sp) `shouldBe` "Internal" + textAttr (csAttributes sp) "keiro.stream.name" `shouldBe` Just "counter-command-otel" + textAttr (csAttributes sp) "db.system.name" `shouldBe` Just "postgresql" + -- keiro.events.appended is an Int64 attribute, not Text. + case lookupAttribute (csAttributes sp) "keiro.events.appended" of + Just (AttributeValue (IntAttribute n)) -> n `shouldBe` 1 + other -> expectationFailure ("expected IntAttribute 1, got " <> show other) + case csStatus sp of + Unset -> pure () + Ok -> pure () + other -> expectationFailure ("expected Unset/Ok, got " <> show other) + + describe "Keiro.Command enrichment parity" $ do + let addMarker eventData = pure (eventData & #metadata %~ injectMarker) + injectMarker = \case + Just (Aeson.Object fields) -> + Just (Aeson.Object (KeyMap.insert "enriched" (Aeson.Bool True) fields)) + _ -> Just (object ["enriched" Aeson..= True]) + installHook = #storeSettings . #enrichEvent ?~ addMarker + hasMarker = \case + Just (Aeson.Object fields) -> + KeyMap.lookup "enriched" fields == Just (Aeson.Bool True) + _ -> False + around (withFreshResourceStoreWith fixture installHook) $ + it "applies the store enrichment hook to both command append paths" $ \(_storeHandle, StoreRunner runner) -> do + let plainTarget = stream "enrich-plain" :: Stream CounterEventStream + transactionalTarget = stream "enrich-transactional" :: Stream CounterEventStream + Right (Right _) <- + runner $ + runCommand defaultRunCommandOptions counterEventStream plainTarget (Add 1) + Right (Right (_, Just callbackRecordeds)) <- + runner $ + runCommandWithSqlEvents + defaultRunCommandOptions + counterEventStream + transactionalTarget + (Add 1) + (\pairs _ -> pure (fmap snd pairs)) + Right plainEvents <- + runner $ + Store.readStreamForward (StreamName "enrich-plain") (StreamVersion 0) 10 + Right transactionalEvents <- + runner $ + Store.readStreamForward (StreamName "enrich-transactional") (StreamVersion 0) 10 + for_ (Vector.toList plainEvents <> Vector.toList transactionalEvents) $ \recorded -> + recorded ^. #metadata `shouldSatisfy` hasMarker + for_ callbackRecordeds $ \recorded -> + recorded ^. #metadata `shouldSatisfy` hasMarker + + describe "Keiro.Snapshot" $ around (withFreshStore fixture) $ do + it "reports an ErrorCall when strict encoding reaches an empty register slot" $ \_storeHandle -> do + result <- + encodeSnapshotStrict + (defaultStateCodec @SnapshotCounterRegs @CounterState 1) + (Counting, emptyRegFile @SnapshotCounterRegs) + case result of + Left err -> displayException err `shouldSatisfy` isInfixOf "uninit: lastAmount" + Right _ -> expectationFailure "expected strict snapshot encoding to fail on an empty register slot" + + it "writes a snapshot after policy threshold" $ \storeHandle -> do + let target = stream "snapshot-write-threshold" :: Stream SnapshotCounterEventStream + Right (Right _) <- + Store.runStoreIO storeHandle $ + runCommand defaultRunCommandOptions snapshotCounterEventStream target (Add 2) + Right (Right _) <- + Store.runStoreIO storeHandle $ + runCommand defaultRunCommandOptions snapshotCounterEventStream target (Add 3) + Right snapshotVersion <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + Tx.statement "snapshot-write-threshold" snapshotVersionForStreamStmt + snapshotVersion `shouldBe` Just (StreamVersion 2) + + it "does not fail a committed command when the post-commit snapshot write fails" $ \storeHandle -> do + (exporter, metricsRef) <- inMemoryMetricExporter + (provider, _env) <- + createMeterProvider + emptyMaterializedResources + defaultSdkMeterProviderOptions{metricExporter = Just exporter} + meter <- getMeter provider Telemetry.keiroInstrumentationLibrary + keiroMetrics <- Telemetry.newKeiroMetrics meter + let target = stream "snapshot-write-failure-swallowed" :: Stream SnapshotCounterEventStream + options = defaultRunCommandOptions & #metrics ?~ keiroMetrics + Right (Right _) <- + Store.runStoreIO storeHandle $ + runCommand options snapshotCounterEventStream target (Add 2) + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + Tx.sql "ALTER TABLE keiro.keiro_snapshots ADD CONSTRAINT keiro_snapshots_no_writes CHECK (false) NOT VALID" + result <- + Store.runStoreIO storeHandle $ + runCommand options snapshotCounterEventStream target (Add 3) + case result of + Right (Right commandResult) -> do + commandResult ^. #streamVersion `shouldBe` StreamVersion 2 + commandResult ^. #eventsAppended `shouldBe` 1 + other -> expectationFailure ("expected committed command despite snapshot failure, got " <> show other) + Right recorded <- + Store.runStoreIO storeHandle $ + Store.readStreamForward (StreamName "snapshot-write-failure-swallowed") (StreamVersion 0) 10 + traverse (decodeRecorded counterCodec) (Vector.toList recorded) + `shouldBe` Right [CounterAdded 2, CounterAdded 3] + Right snapshotVersionDuringFailure <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + Tx.statement "snapshot-write-failure-swallowed" snapshotVersionForStreamStmt + snapshotVersionDuringFailure `shouldBe` Nothing + _ <- forceFlushMeterProvider provider Nothing + exported <- readIORef metricsRef + lookup "keiro.snapshot.write.failures" (flattenScalarPoints exported) `shouldBe` Just (IntNumber 1) + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + Tx.sql "ALTER TABLE keiro.keiro_snapshots DROP CONSTRAINT keiro_snapshots_no_writes" + Right (Right _) <- + Store.runStoreIO storeHandle $ + runCommand options snapshotCounterEventStream target (Add 4) + Right (Right _) <- + Store.runStoreIO storeHandle $ + runCommand options snapshotCounterEventStream target (Add 5) + Right snapshotVersionAfterRecovery <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + Tx.statement "snapshot-write-failure-swallowed" snapshotVersionForStreamStmt + snapshotVersionAfterRecovery `shouldBe` Just (StreamVersion 4) + + it "does not fail a committed command when strict snapshot encoding fails" $ \storeHandle -> do + (exporter, metricsRef) <- inMemoryMetricExporter + (provider, _env) <- + createMeterProvider + emptyMaterializedResources + defaultSdkMeterProviderOptions{metricExporter = Just exporter} + meter <- getMeter provider Telemetry.keiroInstrumentationLibrary + keiroMetrics <- Telemetry.newKeiroMetrics meter + let target = stream "snapshot-encode-failure-swallowed" :: Stream PartialSnapshotEventStream + options = defaultRunCommandOptions & #metrics ?~ keiroMetrics + result <- + Store.runStoreIO storeHandle $ + runCommand options partialSnapshotEventStream target (Add 7) + case result of + Right (Right commandResult) -> do + commandResult ^. #streamVersion `shouldBe` StreamVersion 1 + commandResult ^. #eventsAppended `shouldBe` 1 + other -> expectationFailure ("expected committed command despite snapshot encode failure, got " <> show other) + Right recorded <- + Store.runStoreIO storeHandle $ + Store.readStreamForward (StreamName "snapshot-encode-failure-swallowed") (StreamVersion 0) 10 + traverse (decodeRecorded counterCodec) (Vector.toList recorded) + `shouldBe` Right [CounterAdded 7] + Right snapshotVersion <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + Tx.statement "snapshot-encode-failure-swallowed" snapshotVersionForStreamStmt + snapshotVersion `shouldBe` Nothing + _ <- forceFlushMeterProvider provider Nothing + exported <- readIORef metricsRef + let scalars = flattenScalarPoints exported + lookup "keiro.snapshot.encode.failures" scalars `shouldBe` Just (IntNumber 1) + lookup "keiro.snapshot.write.failures" scalars `shouldBe` Nothing + + it "hydrates from snapshot and replays only the tail" $ \storeHandle -> do + (exporter, metricsRef) <- inMemoryMetricExporter + (provider, _env) <- + createMeterProvider + emptyMaterializedResources + defaultSdkMeterProviderOptions{metricExporter = Just exporter} + meter <- getMeter provider Telemetry.keiroInstrumentationLibrary + keiroMetrics <- Telemetry.newKeiroMetrics meter + let target = stream "snapshot-tail-hydration" :: Stream SnapshotCounterEventStream + options = defaultRunCommandOptions & #metrics ?~ keiroMetrics + Right (Right _) <- + Store.runStoreIO storeHandle $ + runCommand options snapshotCounterEventStream target (Add 2) + Right (Right _) <- + Store.runStoreIO storeHandle $ + runCommand options snapshotCounterEventStream target (Add 3) + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + Tx.statement + ( "snapshot-tail-hydration" + , (defaultStateCodec @SnapshotCounterRegs @CounterState 1 ^. #encode) + (Counting, RCons (Proxy @"lastAmount") 4 RNil) + ) + corruptSnapshotStateStmt + result <- + Store.runStoreIO storeHandle $ + runCommand options guardedSnapshotCounterEventStream target (Add 4) + case result of + Right (Right commandResult) -> + commandResult ^. #streamVersion `shouldBe` StreamVersion 3 + other -> expectationFailure ("expected snapshot-assisted command, got " <> show other) + _ <- forceFlushMeterProvider provider Nothing + exported <- readIORef metricsRef + lookup "keiro.snapshot.read.hits" (flattenScalarPoints exported) `shouldBe` Just (IntNumber 1) + + it "falls back when snapshot JSON is corrupt" $ \storeHandle -> do + (exporter, metricsRef) <- inMemoryMetricExporter + (provider, _env) <- + createMeterProvider + emptyMaterializedResources + defaultSdkMeterProviderOptions{metricExporter = Just exporter} + meter <- getMeter provider Telemetry.keiroInstrumentationLibrary + keiroMetrics <- Telemetry.newKeiroMetrics meter + let target = stream "snapshot-corrupt-json" :: Stream SnapshotCounterEventStream + options = defaultRunCommandOptions & #metrics ?~ keiroMetrics + Right (Right _) <- + Store.runStoreIO storeHandle $ + runCommand options snapshotCounterEventStream target (Add 2) + Right (Right _) <- + Store.runStoreIO storeHandle $ + runCommand options snapshotCounterEventStream target (Add 3) + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + Tx.statement ("snapshot-corrupt-json", Aeson.String "bad") corruptSnapshotStateStmt + result <- + Store.runStoreIO storeHandle $ + runCommand options snapshotCounterEventStream target (Add 4) + case result of + Right (Right commandResult) -> + commandResult ^. #streamVersion `shouldBe` StreamVersion 3 + other -> expectationFailure ("expected corrupt snapshot fallback, got " <> show other) + _ <- forceFlushMeterProvider provider Nothing + exported <- readIORef metricsRef + let scalars = flattenScalarPoints exported + lookup "keiro.snapshot.decode.failures" scalars `shouldBe` Just (IntNumber 1) + lookup "keiro.snapshot.read.misses" scalars `shouldBe` Just (IntNumber 3) + + it "falls back when shape hash mismatches" $ \storeHandle -> do + (exporter, metricsRef) <- inMemoryMetricExporter + (provider, _env) <- + createMeterProvider + emptyMaterializedResources + defaultSdkMeterProviderOptions{metricExporter = Just exporter} + meter <- getMeter provider Telemetry.keiroInstrumentationLibrary + keiroMetrics <- Telemetry.newKeiroMetrics meter + let target = stream "snapshot-shape-mismatch" :: Stream SnapshotCounterEventStream + options = defaultRunCommandOptions & #metrics ?~ keiroMetrics + Right (Right _) <- + Store.runStoreIO storeHandle $ + runCommand options snapshotCounterEventStream target (Add 2) + Right (Right _) <- + Store.runStoreIO storeHandle $ + runCommand options snapshotCounterEventStream target (Add 3) + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + Tx.statement ("snapshot-shape-mismatch", "stale-shape") corruptSnapshotShapeStmt + result <- + Store.runStoreIO storeHandle $ + runCommand options snapshotCounterEventStream target (Add 4) + case result of + Right (Right commandResult) -> + commandResult ^. #streamVersion `shouldBe` StreamVersion 3 + other -> expectationFailure ("expected stale shape fallback, got " <> show other) + _ <- forceFlushMeterProvider provider Nothing + exported <- readIORef metricsRef + let scalars = flattenScalarPoints exported + lookup "keiro.snapshot.read.misses" scalars `shouldBe` Just (IntNumber 3) + lookup "keiro.snapshot.decode.failures" scalars `shouldBe` Nothing + + it "falls back after operator truncation" $ \storeHandle -> do + (exporter, metricsRef) <- inMemoryMetricExporter + (provider, _env) <- + createMeterProvider + emptyMaterializedResources + defaultSdkMeterProviderOptions{metricExporter = Just exporter} + meter <- getMeter provider Telemetry.keiroInstrumentationLibrary + keiroMetrics <- Telemetry.newKeiroMetrics meter + let target = stream "snapshot-operator-truncate" :: Stream SnapshotCounterEventStream + options = defaultRunCommandOptions & #metrics ?~ keiroMetrics + Right (Right _) <- + Store.runStoreIO storeHandle $ + runCommand options snapshotCounterEventStream target (Add 2) + Right (Right _) <- + Store.runStoreIO storeHandle $ + runCommand options snapshotCounterEventStream target (Add 3) + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + Tx.sql "TRUNCATE keiro.keiro_snapshots" + result <- + Store.runStoreIO storeHandle $ + runCommand options snapshotCounterEventStream target (Add 4) + case result of + Right (Right commandResult) -> + commandResult ^. #streamVersion `shouldBe` StreamVersion 3 + other -> expectationFailure ("expected truncation fallback, got " <> show other) + _ <- forceFlushMeterProvider provider Nothing + exported <- readIORef metricsRef + let scalars = flattenScalarPoints exported + lookup "keiro.snapshot.read.misses" scalars `shouldBe` Just (IntNumber 3) + lookup "keiro.snapshot.decode.failures" scalars `shouldBe` Nothing + + it "writes snapshots after applying a complete multi-event command batch" $ \storeHandle -> do + let target = stream "snapshot-multi-event-batch" :: Stream SnapshotCounterEventStream + result <- + Store.runStoreIO storeHandle $ + runCommand defaultRunCommandOptions multiSnapshotCounterEventStream target (Add 9) + case result of + Right (Right commandResult) -> do + commandResult ^. #streamVersion `shouldBe` StreamVersion 2 + commandResult ^. #eventsAppended `shouldBe` 2 + other -> expectationFailure ("expected multi-event snapshot command, got " <> show other) + Right snapshotVersion <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + Tx.statement "snapshot-multi-event-batch" snapshotVersionForStreamStmt + snapshotVersion `shouldBe` Just (StreamVersion 2) + + it "writes a snapshot when a multi-event append crosses an Every boundary" $ \storeHandle -> do + let target = stream "snapshot-multi-event-crosses-boundary" :: Stream SnapshotCounterEventStream + boundaryEventStream :: SnapshotCounterEventStream + boundaryEventStream = + snapshotCounterEventStreamDef + & #transducer + .~ multiSnapshotCounterTransducer + & #snapshotPolicy + .~ Every 3 + validatedBoundaryEventStream = mkEventStreamOrThrow "snapshot-multi-event-crosses-boundary" boundaryEventStream + Right (Right _) <- + Store.runStoreIO storeHandle $ + runCommand defaultRunCommandOptions validatedBoundaryEventStream target (Add 2) + Right firstSnapshotVersion <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + Tx.statement "snapshot-multi-event-crosses-boundary" snapshotVersionForStreamStmt + firstSnapshotVersion `shouldBe` Nothing + result <- + Store.runStoreIO storeHandle $ + runCommand defaultRunCommandOptions validatedBoundaryEventStream target (Add 3) + case result of + Right (Right commandResult) -> + commandResult ^. #streamVersion `shouldBe` StreamVersion 4 + other -> expectationFailure ("expected successful boundary-crossing command, got " <> show other) + Right snapshotVersion <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + Tx.statement "snapshot-multi-event-crosses-boundary" snapshotVersionForStreamStmt + snapshotVersion `shouldBe` Just (StreamVersion 4) + + it "allows an incompatible snapshot codec to replace a higher-version row" $ \storeHandle -> do + let target = stream "snapshot-codec-rollback-overwrite" :: Stream SnapshotCounterEventStream + Right (Right _) <- + Store.runStoreIO storeHandle $ + runCommand defaultRunCommandOptions snapshotCounterEventStream target (Add 1) + Right (Right _) <- + Store.runStoreIO storeHandle $ + runCommand defaultRunCommandOptions snapshotCounterEventStream target (Add 2) + Right (Right _) <- + Store.runStoreIO storeHandle $ + runCommand defaultRunCommandOptions snapshotCounterEventStream target (Add 3) + Right (Right _) <- + Store.runStoreIO storeHandle $ + runCommand defaultRunCommandOptions snapshotCounterEventStream target (Add 4) + Right snapshotVersionBefore <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + Tx.statement "snapshot-codec-rollback-overwrite" snapshotVersionForStreamStmt + snapshotVersionBefore `shouldBe` Just (StreamVersion 4) + let rollbackCodec = defaultStateCodec @SnapshotCounterRegs @CounterState 2 + streamId <- + Store.runStoreIO storeHandle (Store.lookupStreamId (StreamName "snapshot-codec-rollback-overwrite")) >>= \case + Right (Just sid) -> pure sid + other -> expectationFailure ("expected stream id, got " <> show other) *> error "unreachable" + Right () <- + Store.runStoreIO storeHandle $ + writeSnapshotRow + SnapshotWrite + { streamId = streamId + , streamVersion = StreamVersion 2 + , state = (rollbackCodec ^. #encode) (Counting, RCons (Proxy @"lastAmount") 2 RNil) + , stateCodecVersion = rollbackCodec ^. #stateCodecVersion + , regfileShapeHash = rollbackCodec ^. #shapeHash + } + Right snapshotVersionAfter <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + Tx.statement "snapshot-codec-rollback-overwrite" snapshotVersionForStreamStmt + snapshotVersionAfter `shouldBe` Just (StreamVersion 2) + + describe "Keiro.Connection projection schema" $ + around (withFreshResourceStoreWith fixture (withProjectionSchema "app_reads")) $ do + it "places a read-model table in a configured schema, separate from keiro metadata" $ \(storeHandle, StoreRunner runner) -> do + -- qualifiedTableName builds the app's fully-qualified data table ref. + qualifiedTableName placedReadModel `shouldBe` "\"app_reads\".\"placed_counter\"" + + -- Create the app schema (opt-in) and the qualified read-model table. + Right () <- + Store.runStoreIO storeHandle $ do + ensureProjectionSchema "app_reads" + initializeRegisteredReadModel placedReadModel initializePlacedTable + + -- Drive a command with the inline projection that writes the app table. + let target = stream "placed-in-app-reads" :: Stream CounterEventStream + result <- + runner $ + runCommandWithProjections + defaultRunCommandOptions + counterEventStream + target + (Add 7) + [placedInlineProjection] + case result of + Right (Right _) -> pure () + other -> expectationFailure ("expected placed inline projection command, got " <> show other) + + -- Read it back through the configured-schema read model. + queryResult <- + Store.runStoreIO storeHandle $ + runQuery Nothing placedReadModel "placed" + queryResult `shouldBe` Right (Right 7) + + -- Prove placement: the app table is in app_reads, NOT in kiroku, and + -- Keiro's own metadata (keiro_read_models) is in the keiro schema. + Right (inApp, inKiroku, keiroMeta) <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + (,,) + <$> Tx.statement ("app_reads", "placed_counter") pgTableCountStmt + <*> Tx.statement ("kiroku", "placed_counter") pgTableCountStmt + <*> Tx.statement ("keiro", "keiro_read_models") pgTableCountStmt + inApp `shouldBe` (1 :: Int) + inKiroku `shouldBe` (0 :: Int) + keiroMeta `shouldBe` (1 :: Int) + + describe "Keiro.ReadModel" $ around (withFreshStore fixture) $ do + it "queries inline projection with Eventual consistency" $ \_ -> + withFreshResourceStore fixture $ \(storeHandle, StoreRunner runner) -> do + Right () <- + Store.runStoreIO storeHandle $ + initializeRegisteredReadModel counterReadModel initializeCounterReadModelTable + let target = stream "read-model-inline" :: Stream CounterEventStream + result <- + runner $ + runCommandWithProjections + defaultRunCommandOptions + counterEventStream + target + (Add 5) + [counterInlineProjection] + case result of + Right (Right commandResult) -> + commandResult ^. #globalPosition `shouldSatisfy` isJust + other -> expectationFailure ("expected inline projection command, got " <> show other) + queryResult <- + Store.runStoreIO storeHandle $ + runQuery Nothing counterReadModel "inline" + queryResult `shouldBe` Right (Right 5) + + it "reads the minimum checkpoint across consumer-group subscription members" $ \storeHandle -> do + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ do + Tx.statement ("counter-read-model-sub", 1, 7) upsertSubscriptionCursorMemberStmt + Tx.statement ("counter-read-model-sub", 2, 3) upsertSubscriptionCursorMemberStmt + position <- + Store.runStoreIO storeHandle $ + readSubscriptionPosition "counter-read-model-sub" + position `shouldBe` Right (Just (GlobalPosition 3)) + + it "Strong returns immediately on an empty log" $ \storeHandle -> do + Right () <- + Store.runStoreIO storeHandle $ + initializeRegisteredReadModel counterReadModel initializeCounterReadModelTable + queryResult <- + Store.runStoreIO storeHandle $ + runQueryWith Nothing Strong counterReadModel "empty" + queryResult `shouldBe` Right (Right 0) + + it "Strong returns immediately when the subscription is already at the store head" $ \_ -> + withFreshResourceStore fixture $ \(storeHandle, StoreRunner runner) -> do + Right () <- + Store.runStoreIO storeHandle $ + initializeRegisteredReadModel counterReadModel initializeCounterReadModelTable + let target = stream "read-model-strong-at-head" :: Stream CounterEventStream + Right (Right commandResult) <- + runner $ + runCommandWithProjections + defaultRunCommandOptions + counterEventStream + target + (Add 5) + [counterInlineProjection] + globalPosition <- case commandResult ^. #globalPosition of + Just position -> pure position + Nothing -> expectationFailure "expected command global position" *> error "unreachable" + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + Tx.statement ("counter-read-model-sub", globalPositionToInt globalPosition) upsertSubscriptionCursorStmt + queryResult <- + Store.runStoreIO storeHandle $ + runQueryWith Nothing Strong counterReadModel "inline" + queryResult `shouldBe` Right (Right 5) + + it "Strong blocks until the subscription reaches the store head captured at query start" $ \_ -> + withFreshResourceStore fixture $ \(storeHandle, StoreRunner runner) -> do + Right () <- + Store.runStoreIO storeHandle $ + initializeRegisteredReadModel counterReadModel initializeCounterReadModelTable + let target = stream "read-model-strong-blocking" :: Stream CounterEventStream + Right (Right commandResult) <- + runner $ + runCommandWithProjections + defaultRunCommandOptions + counterEventStream + target + (Add 6) + [counterInlineProjection] + globalPosition <- case commandResult ^. #globalPosition of + Just position -> pure position + Nothing -> expectationFailure "expected command global position" *> error "unreachable" + _ <- forkIO $ do + threadDelay 20000 + advanced <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + Tx.statement ("counter-read-model-sub", globalPositionToInt globalPosition) upsertSubscriptionCursorStmt + case advanced of + Right () -> pure () + Left err -> expectationFailure ("failed to advance subscription cursor: " <> show err) + queryResult <- + Store.runStoreIO storeHandle $ + runQueryWith Nothing Strong counterReadModel "inline" + queryResult `shouldBe` Right (Right 6) + + it "Strong returns when its category is caught up despite another active category" $ \_ -> + withFreshResourceStore fixture $ \(storeHandle, StoreRunner runner) -> do + Right () <- + Store.runStoreIO storeHandle $ + initializeRegisteredReadModel counterReadModel initializeCounterReadModelTable + let counterTarget = stream "counter-strong-scope" :: Stream CounterEventStream + otherTarget = stream "otherload-1" :: Stream CounterEventStream + Right (Right counterResult) <- + runner $ + runCommandWithProjections + defaultRunCommandOptions + counterEventStream + counterTarget + (Add 8) + [counterInlineProjection] + counterPosition <- case counterResult ^. #globalPosition of + Just position -> pure position + Nothing -> expectationFailure "expected counter global position" *> error "unreachable" + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + Tx.statement + ("counter-read-model-sub", globalPositionToInt counterPosition) + upsertSubscriptionCursorStmt + Right (Right _) <- + Store.runStoreIO storeHandle $ + runCommand defaultRunCommandOptions counterEventStream otherTarget (Add 1) + queryResult <- + Store.runStoreIO storeHandle $ + runQueryWith Nothing Strong counterCategoryReadModel "inline" + queryResult `shouldBe` Right (Right 8) + + it "inline projection populates actor and source_event_id from command metadata" $ \_ -> + withFreshResourceStore fixture $ \(storeHandle, StoreRunner runner) -> do + Right () <- + Store.runStoreIO storeHandle $ + initializeRegisteredReadModel counterReadModel initializeCounterReadModelTable + let target = stream "read-model-inline-metadata" :: Stream CounterEventStream + opts = + defaultRunCommandOptions + & #metadata + ?~ object ["actor" Aeson..= ("agent-7" :: Text)] + Right (Right _) <- + runner $ + runCommandWithProjections opts counterEventStream target (Add 5) [counterInlineProjection] + Right row <- + Store.runStoreIO storeHandle $ + Store.runTransaction (Tx.statement "inline" selectCounterMetaStmt) + -- selectCounterMetaStmt returns (amount, actor, source_event_id). + row `shouldSatisfy` \(amount, actor, srcId) -> + amount == 5 && actor == Just "agent-7" && isJust srcId + + it "waits for async projection cursor with PositionWait" $ \_ -> + withFreshResourceStore fixture $ \(storeHandle, StoreRunner runner) -> do + Right () <- + Store.runStoreIO storeHandle $ + initializeRegisteredReadModel counterReadModel initializeCounterReadModelTable + let target = stream "read-model-position-wait" :: Stream CounterEventStream + Right (Right commandResult) <- + runner $ + runCommandWithProjections + defaultRunCommandOptions + counterEventStream + target + (Add 3) + [counterInlineProjection] + globalPosition <- case commandResult ^. #globalPosition of + Just position -> pure position + Nothing -> expectationFailure "expected command global position" *> error "unreachable" + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + Tx.statement ("counter-read-model-sub", globalPositionToInt globalPosition) upsertSubscriptionCursorStmt + queryResult <- + Store.runStoreIO storeHandle $ + runQueryWith + Nothing + (PositionWait (fastWaitOptions & #target .~ Just globalPosition)) + counterReadModel + "inline" + queryResult `shouldBe` Right (Right 3) + + it "times out when PositionWait target is not reached" $ \storeHandle -> do + Right () <- + Store.runStoreIO storeHandle $ + initializeRegisteredReadModel counterReadModel initializeCounterReadModelTable + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + Tx.statement ("counter-read-model-sub", 1) upsertSubscriptionCursorStmt + queryResult <- + Store.runStoreIO storeHandle $ + runQueryWith + Nothing + (PositionWait (fastWaitOptions & #target .~ Just (GlobalPosition 5))) + counterReadModel + "timeout" + queryResult + `shouldBe` Right + (Left (ReadModelWaitTimeout "counter-read-model" (GlobalPosition 5) (GlobalPosition 1))) + + it "does not write the registry row on repeated read-model queries" $ \storeHandle -> do + Right () <- + Store.runStoreIO storeHandle $ + initializeRegisteredReadModel counterReadModel initializeCounterReadModelTable + Right (Right 0) <- + Store.runStoreIO storeHandle $ + runQuery Nothing counterReadModel "no-churn" + Right xminBefore <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + Tx.statement "counter-read-model" readModelXminStmt + Right (Right 0) <- + Store.runStoreIO storeHandle $ + runQuery Nothing counterReadModel "no-churn" + Right xminAfter <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + Tx.statement "counter-read-model" readModelXminStmt + xminAfter `shouldBe` xminBefore + + it "rejects an unregistered model without creating a registry row" $ \storeHandle -> do + let unregistered :: ReadModel Text Int + unregistered = counterReadModel & #name .~ ("never-registered" :: Text) + queryResult <- + Store.runStoreIO storeHandle $ + runQuery Nothing unregistered "missing" + queryResult `shouldBe` Right (Left (ReadModelUnregistered "never-registered")) + found <- + Store.runStoreIO storeHandle $ + lookupReadModel "never-registered" + found `shouldBe` Right Nothing + + it "handles concurrent explicit read-model registration" $ \storeHandle -> do + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction initializeCounterReadModelTable + resultA <- newEmptyMVar + resultB <- newEmptyMVar + _ <- + forkIO $ + Store.runStoreIO storeHandle (registerReadModelDefinition counterReadModel) + >>= putMVar resultA + _ <- + forkIO $ + Store.runStoreIO storeHandle (registerReadModelDefinition counterReadModel) + >>= putMVar resultB + first <- takeMVar resultA + second <- takeMVar resultB + first `shouldBe` Right () + second `shouldBe` Right () + queryResult <- + Store.runStoreIO storeHandle $ + runQuery Nothing counterReadModel "concurrent" + queryResult `shouldBe` Right (Right 0) + + it "rejects stale read-model schema" $ \storeHandle -> do + Right () <- + Store.runStoreIO storeHandle $ + initializeRegisteredReadModel counterReadModel initializeCounterReadModelTable + Right (Right 0) <- + Store.runStoreIO storeHandle $ + runQuery Nothing counterReadModel "stale" + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + Tx.statement ("counter-read-model", 99) updateReadModelVersionStmt + queryResult <- + Store.runStoreIO storeHandle $ + runQuery Nothing counterReadModel "stale" + queryResult + `shouldBe` Right + (Left (ReadModelStaleSchema "counter-read-model" 1 99 "counter-read-model-v1" "counter-read-model-v1")) + + it "surfaces unknown read-model statuses with the raw status text" $ \storeHandle -> do + Right () <- + Store.runStoreIO storeHandle $ + initializeRegisteredReadModel counterReadModel initializeCounterReadModelTable + Right (Right 0) <- + Store.runStoreIO storeHandle $ + runQuery Nothing counterReadModel "unknown-status" + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + Tx.statement ("counter-read-model", "wedged") updateReadModelStatusStmt + queryResult <- + Store.runStoreIO storeHandle $ + runQuery Nothing counterReadModel "unknown-status" + queryResult + `shouldBe` Right + (Left (ReadModelNotLive "counter-read-model" (UnknownStatus "wedged"))) + + it "ignores duplicate async event by source_event_id" $ \storeHandle -> do + Right () <- + Store.runStoreIO storeHandle $ + initializeRegisteredReadModel counterReadModel initializeCounterReadModelTable + let target = stream "read-model-async-idempotent" :: Stream CounterEventStream + Right (Right _) <- + Store.runStoreIO storeHandle $ + runCommand defaultRunCommandOptions counterEventStream target (Add 7) + Right recorded <- + Store.runStoreIO storeHandle $ + Store.readStreamForward (StreamName "read-model-async-idempotent") (StreamVersion 0) 10 + event <- case Vector.toList recorded of + [onlyEvent] -> pure onlyEvent + other -> expectationFailure ("expected one event, got " <> show other) *> error "unreachable" + Right outcomes <- Store.runStoreIO storeHandle $ + Store.runTransaction $ do + first <- applyAsyncProjection counterAsyncProjection event + second <- applyAsyncProjection counterAsyncProjection event + pure (first, second) + outcomes `shouldBe` (AsyncApplied, AsyncDuplicate) + queryResult <- + Store.runStoreIO storeHandle $ + runQuery Nothing counterReadModel "async-idempotent" + queryResult `shouldBe` Right (Right 7) + + it "deduplicates async projection application across transactions and reopens after pruning" $ \storeHandle -> do + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction initializeProjectionDedupCounterTable + Right _ <- + Store.runStoreIO storeHandle $ + registerReadModel "projection-dedup-counter-model" 1 "projection-dedup-counter-v1" + let target = stream "read-model-async-dedup-window" :: Stream CounterEventStream + Right (Right _) <- + Store.runStoreIO storeHandle $ + runCommand defaultRunCommandOptions counterEventStream target (Add 7) + Right recorded <- + Store.runStoreIO storeHandle $ + Store.readStreamForward (StreamName "read-model-async-dedup-window") (StreamVersion 0) 10 + event <- case Vector.toList recorded of + [onlyEvent] -> pure onlyEvent + other -> expectationFailure ("expected one event, got " <> show other) *> error "unreachable" + let incrementingProjection = + AsyncProjection + { name = "incrementing-async-projection" + , readModelName = "projection-dedup-counter-model" + , subscriptionName = "incrementing-async-projection-sub" + , applyRecorded = \_ -> Tx.statement () incrementProjectionDedupCounterStmt + , idempotencyKey = \recordedEvent -> recordedEvent ^. #eventId + } + Right AsyncApplied <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + applyAsyncProjection incrementingProjection event + Right AsyncDuplicate <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + applyAsyncProjection incrementingProjection event + Right countAfterDuplicate <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + Tx.statement () selectProjectionDedupCounterStmt + countAfterDuplicate `shouldBe` 1 + cutoff <- addUTCTime 1 <$> getCurrentTime + pruned <- Store.runStoreIO storeHandle $ pruneAsyncProjectionDedupBefore cutoff + pruned `shouldBe` Right 1 + Right AsyncApplied <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + applyAsyncProjection incrementingProjection event + Right countAfterPrune <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + Tx.statement () selectProjectionDedupCounterStmt + countAfterPrune `shouldBe` 2 + + it "rebuild repopulates the projection table through the supported workflow" $ \storeHandle -> do + Right () <- + Store.runStoreIO storeHandle $ + initializeRegisteredReadModel counterReadModel initializeCounterReadModelTable + let target = stream "read-model-rebuild-runbook" :: Stream CounterEventStream + Right (Right _) <- + Store.runStoreIO storeHandle $ + runCommand defaultRunCommandOptions counterEventStream target (Add 7) + Right recorded <- + Store.runStoreIO storeHandle $ + Store.readStreamForward (StreamName "read-model-rebuild-runbook") (StreamVersion 0) 10 + event <- case Vector.toList recorded of + [onlyEvent] -> pure onlyEvent + other -> expectationFailure ("expected one event, got " <> show other) *> error "unreachable" + Right AsyncApplied <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + applyAsyncProjection counterAsyncProjection event + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + Tx.statement + ( "counter-read-model-sub" + , globalPositionToInt (event ^. #globalPosition) + ) + upsertSubscriptionCursorStmt + beforeRebuild <- + Store.runStoreIO storeHandle $ + runQuery Nothing counterReadModel "async-idempotent" + beforeRebuild `shouldBe` Right (Right 7) + + Right rebuilding <- + Store.runStoreIO storeHandle $ + Rebuild.startRebuild + counterReadModel + [counterAsyncProjection ^. #name] + (GlobalPosition 0) + rebuilding ^. #status `shouldBe` Rebuilding + checkpointAfterReset <- + Store.runStoreIO storeHandle $ + readSubscriptionPosition "counter-read-model-sub" + checkpointAfterReset `shouldBe` Right (Just (GlobalPosition 0)) + Right AsyncApplied <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + applyAsyncProjectionUnfenced counterAsyncProjection event + Right (Right live) <- + Store.runStoreIO storeHandle $ + Rebuild.finishRebuild + counterReadModel + [counterAsyncProjection ^. #name] + (GlobalPosition 0) + live ^. #status `shouldBe` Live + + afterRebuild <- + Store.runStoreIO storeHandle $ + runQuery Nothing counterReadModel "async-idempotent" + afterRebuild `shouldBe` Right (Right 7) + + it "keeps a non-empty-log rebuild offline when replay applies nothing" $ \storeHandle -> do + Right () <- + Store.runStoreIO storeHandle $ + initializeRegisteredReadModel counterReadModel initializeCounterReadModelTable + let target = stream "read-model-rebuild-empty-replay" :: Stream CounterEventStream + Right (Right _) <- + Store.runStoreIO storeHandle $ + runCommand defaultRunCommandOptions counterEventStream target (Add 7) + Right _ <- + Store.runStoreIO storeHandle $ + Rebuild.startRebuild + counterReadModel + [counterAsyncProjection ^. #name] + (GlobalPosition 0) + finishResult <- + Store.runStoreIO storeHandle $ + Rebuild.finishRebuild + counterReadModel + [counterAsyncProjection ^. #name] + (GlobalPosition 0) + case finishResult of + Right (Left (Rebuild.RebuildProducedNoApplies modelName headPosition)) -> do + modelName `shouldBe` "counter-read-model" + headPosition `shouldSatisfy` (> GlobalPosition 0) + other -> expectationFailure ("expected zero-apply guard, got " <> show other) + queryResult <- + Store.runStoreIO storeHandle $ + runQuery Nothing counterReadModel "async-idempotent" + queryResult + `shouldBe` Right + (Left (ReadModelNotLive "counter-read-model" Rebuilding)) + + it "fences live async application while a model is rebuilding" $ \storeHandle -> do + Right () <- + Store.runStoreIO storeHandle $ + initializeRegisteredReadModel counterReadModel initializeCounterReadModelTable + let target = stream "read-model-fenced-apply" :: Stream CounterEventStream + Right (Right _) <- + Store.runStoreIO storeHandle $ + runCommand defaultRunCommandOptions counterEventStream target (Add 7) + Right recorded <- + Store.runStoreIO storeHandle $ + Store.readStreamForward (StreamName "read-model-fenced-apply") (StreamVersion 0) 10 + event <- case Vector.toList recorded of + [onlyEvent] -> pure onlyEvent + other -> expectationFailure ("expected one event, got " <> show other) *> error "unreachable" + Right _ <- + Store.runStoreIO storeHandle $ + Rebuild.startRebuild + counterReadModel + [counterAsyncProjection ^. #name] + (GlobalPosition 0) + outcome <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + applyAsyncProjection counterAsyncProjection event + outcome `shouldBe` Right AsyncFenced + Right dedupCount <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + Tx.statement (counterAsyncProjection ^. #name) projectionDedupCountStmt + dedupCount `shouldBe` 0 + Right amount <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + Tx.statement "async-idempotent" selectCounterReadModelStmt + amount `shouldBe` 0 + + it "keeps a live applier out of the rebuild window and reopens it after promotion" $ \storeHandle -> do + Right () <- + Store.runStoreIO storeHandle $ + initializeRegisteredReadModel counterReadModel initializeCounterReadModelTable + let target = stream "read-model-fence-race" :: Stream CounterEventStream + Right (Right _) <- + Store.runStoreIO storeHandle $ + runCommand defaultRunCommandOptions counterEventStream target (Add 7) + Right recorded <- + Store.runStoreIO storeHandle $ + Store.readStreamForward (StreamName "read-model-fence-race") (StreamVersion 0) 10 + event <- case Vector.toList recorded of + [onlyEvent] -> pure onlyEvent + other -> expectationFailure ("expected one event, got " <> show other) *> error "unreachable" + enterRebuildWindow <- newEmptyMVar + liveApplyResult <- newEmptyMVar + _ <- + forkIO $ do + takeMVar enterRebuildWindow + Store.runStoreIO + storeHandle + (Store.runTransaction (applyAsyncProjection counterAsyncProjection event)) + >>= putMVar liveApplyResult + Right _ <- + Store.runStoreIO storeHandle $ + Rebuild.startRebuild + counterReadModel + [counterAsyncProjection ^. #name] + (GlobalPosition 0) + putMVar enterRebuildWindow () + takeMVar liveApplyResult `shouldReturn` Right AsyncFenced + + Right AsyncApplied <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + applyAsyncProjectionUnfenced counterAsyncProjection event + Right (Right _) <- + Store.runStoreIO storeHandle $ + Rebuild.finishRebuild + counterReadModel + [counterAsyncProjection ^. #name] + (GlobalPosition 0) + cutoff <- addUTCTime 1 <$> getCurrentTime + pruned <- Store.runStoreIO storeHandle $ pruneAsyncProjectionDedupBefore cutoff + pruned `shouldBe` Right 1 + reapplied <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + applyAsyncProjection counterAsyncProjection event + reapplied `shouldBe` Right AsyncApplied + queryResult <- + Store.runStoreIO storeHandle $ + runQuery Nothing counterReadModel "async-idempotent" + queryResult `shouldBe` Right (Right 7) + + it "tracks rebuild state transitions" $ \storeHandle -> do + Right () <- + Store.runStoreIO storeHandle $ + registerReadModelDefinition counterReadModel + Right rebuilding <- + Store.runStoreIO storeHandle $ + Rebuild.rebuild counterReadModel + rebuilding ^. #status `shouldBe` Rebuilding + Right live <- + Store.runStoreIO storeHandle $ + Rebuild.promote counterReadModel + live ^. #status `shouldBe` Live + Right abandoned <- + Store.runStoreIO storeHandle $ + Rebuild.abandonRebuild counterReadModel + abandoned ^. #status `shouldBe` Abandoned + + it "records projection lag behind the log head" $ \storeHandle -> do + (exporter, metricsRef) <- inMemoryMetricExporter + (provider, _env) <- + createMeterProvider + emptyMaterializedResources + defaultSdkMeterProviderOptions{metricExporter = Just exporter} + meter <- getMeter provider Telemetry.keiroInstrumentationLibrary + keiroMetrics <- Telemetry.newKeiroMetrics meter + Right () <- + Store.runStoreIO storeHandle $ + initializeRegisteredReadModel counterReadModel initializeCounterReadModelTable + let target = stream "read-model-lag" :: Stream CounterEventStream + Right (Right _) <- + Store.runStoreIO storeHandle $ + runCommand defaultRunCommandOptions counterEventStream target (Add 1) + Right (Right _) <- + Store.runStoreIO storeHandle $ + runCommand defaultRunCommandOptions counterEventStream target (Add 1) + -- The subscription cursor is never advanced, so the read model is behind + -- the head by every appended event: the lag gauge records that gap. + Right () <- + Store.runStoreIO storeHandle $ + recordProjectionLag (Just keiroMetrics) counterAsyncProjection + _ <- forceFlushMeterProvider provider Nothing + exported <- readIORef metricsRef + let scalars = flattenScalarPoints exported + case lookup "keiro.projection.lag" scalars of + Just (IntNumber n) -> n `shouldSatisfy` (>= 1) + other -> expectationFailure ("expected an integer projection lag, got " <> show other) + + it "counts a position-wait timeout in the timeout counter" $ \storeHandle -> do + (exporter, metricsRef) <- inMemoryMetricExporter + (provider, _env) <- + createMeterProvider + emptyMaterializedResources + defaultSdkMeterProviderOptions{metricExporter = Just exporter} + meter <- getMeter provider Telemetry.keiroInstrumentationLibrary + keiroMetrics <- Telemetry.newKeiroMetrics meter + Right () <- + Store.runStoreIO storeHandle $ + initializeRegisteredReadModel counterReadModel initializeCounterReadModelTable + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + Tx.statement ("counter-read-model-sub", 1) upsertSubscriptionCursorStmt + queryResult <- + Store.runStoreIO storeHandle $ + runQueryWith + (Just keiroMetrics) + (PositionWait (fastWaitOptions & #target .~ Just (GlobalPosition 5))) + counterReadModel + "timeout" + queryResult + `shouldBe` Right + (Left (ReadModelWaitTimeout "counter-read-model" (GlobalPosition 5) (GlobalPosition 1))) + _ <- forceFlushMeterProvider provider Nothing + exported <- readIORef metricsRef + let scalars = flattenScalarPoints exported + -- The single give-up bumped the counter exactly once. + lookup "keiro.projection.wait.timeouts" scalars `shouldBe` Just (IntNumber 1) + + describe "Keiro.ProcessManager" $ around (withFreshResourceStore fixture) $ do + it "advances manager state, emits a deterministic target command once, and schedules a timer" $ \(_storeHandle, StoreRunner _runner) -> do + let sourceEvent = recordedFromEventId (EventId sampleUuid) (CounterAdded 9) + result <- + _runner $ + runProcessManagerOnce defaultRunCommandOptions counterProcessManager sourceEvent (CounterAdded 9) + case result of + Right (Right pmResult) -> do + case pmResult ^. #managerResult of + PMStateAppended managerResult -> + managerResult ^. #streamVersion `shouldBe` StreamVersion 1 + other -> expectationFailure ("expected appended manager state, got " <> show other) + case pmResult ^. #commandResults of + [PMCommandAppended commandResult] -> + commandResult ^. #eventsAppended `shouldBe` 1 + other -> expectationFailure ("expected one emitted command, got " <> show other) + pmResult ^. #timersScheduled `shouldBe` 1 + other -> expectationFailure ("expected process-manager success, got " <> show other) + Right managerEvents <- + _runner $ + Store.readStreamForward (StreamName "pm:counter-order-1") (StreamVersion 0) 10 + Right targetEvents <- + _runner $ + Store.readStreamForward (StreamName "counter-target-order-1") (StreamVersion 0) 10 + Vector.length managerEvents `shouldBe` 1 + Vector.length targetEvents `shouldBe` 1 + timer <- + _runner $ + claimDueTimer dueTimerTime + case timer of + Right (Just row) -> do + row ^. #processManagerName `shouldBe` "counter-pm" + row ^. #correlationId `shouldBe` "order-1" + other -> expectationFailure ("expected scheduled timer row, got " <> show other) + + it "schedules timers when the manager command emits no events" $ \(_storeHandle, StoreRunner _runner) -> do + let sourceEvent = recordedFromEventId (EventId sampleUuid) (CounterAdded 9) + result <- + _runner $ + runProcessManagerOnce defaultRunCommandOptions timerOnlyProcessManager sourceEvent (CounterAdded 9) + case result of + Right (Right pmResult) -> do + case pmResult ^. #managerResult of + PMStateAppended managerResult -> do + managerResult ^. #streamVersion `shouldBe` StreamVersion 0 + managerResult ^. #eventsAppended `shouldBe` 0 + other -> expectationFailure ("expected no-op manager state, got " <> show other) + pmResult ^. #commandResults `shouldBe` [] + pmResult ^. #timersScheduled `shouldBe` 1 + other -> expectationFailure ("expected process-manager success, got " <> show other) + dueCount <- + _runner $ + countDueTimers dueTimerTime + dueCount `shouldBe` Right 1 + timer <- + _runner $ + claimDueTimer dueTimerTime + case timer of + Right (Just row) -> do + row ^. #processManagerName `shouldBe` "timer-only-pm" + row ^. #correlationId `shouldBe` "order-1" + other -> expectationFailure ("expected scheduled timer row, got " <> show other) + + it "treats duplicate input delivery as idempotent state and command dispatch" $ \(_storeHandle, StoreRunner _runner) -> do + let sourceEvent = recordedFromEventId (EventId sampleUuid2) (CounterAdded 4) + Right (Right _) <- + _runner $ + runProcessManagerOnce defaultRunCommandOptions counterProcessManager sourceEvent (CounterAdded 4) + duplicate <- + _runner $ + runProcessManagerOnce defaultRunCommandOptions counterProcessManager sourceEvent (CounterAdded 4) + case duplicate of + Right (Right pmResult) -> do + pmResult ^. #managerResult `shouldSatisfy` \case + PMStateDuplicate{} -> True + _ -> False + pmResult ^. #commandResults `shouldSatisfy` \case + [PMCommandDuplicate{}] -> True + _ -> False + other -> expectationFailure ("expected idempotent duplicate handling, got " <> show other) + Right managerEvents <- + _runner $ + Store.readStreamForward (StreamName "pm:counter-order-1") (StreamVersion 0) 10 + Right targetEvents <- + _runner $ + Store.readStreamForward (StreamName "counter-target-order-1") (StreamVersion 0) 10 + Vector.length managerEvents `shouldBe` 1 + Vector.length targetEvents `shouldBe` 1 + + it "replays a Kiroku dead letter freshly and deduplicates a second replay" $ \(_storeHandle, StoreRunner _runner) -> do + let subName = SubscriptionName "counter-pm-replay-fresh" + replayHandler recorded = + case decodeRecorded counterCodec recorded of + Left err -> pure (Left (Text.pack (show err))) + Right input -> do + outcome <- + runProcessManagerOnce + defaultRunCommandOptions + counterProcessManager + recorded + input + pure $ + case outcome of + Left err -> Left (Text.pack (show err)) + Right result -> Right (classifyProcessManagerReplay result) + source <- deadLetterCounterSource _storeHandle subName (CounterAdded 7) + Right listed <- _runner (listSubscriptionDeadLetters subName 0) + Vector.length listed `shouldBe` 1 + + Right firstPass <- + _runner $ + replaySubscriptionDeadLetters subName 0 replayHandler + firstPass + `shouldBe` [ ReplayOutcome + { replayGlobalPosition = source ^. #globalPosition + , replayEventId = source ^. #eventId + , replayResult = ReplayedFresh + } + ] + processManagerReplayCounts _storeHandle `shouldReturn` (1, 1) + + Right secondPass <- + _runner $ + replaySubscriptionDeadLetters subName 0 replayHandler + secondPass + `shouldBe` [ ReplayOutcome + { replayGlobalPosition = source ^. #globalPosition + , replayEventId = source ^. #eventId + , replayResult = ReplayedDuplicate + } + ] + processManagerReplayCounts _storeHandle `shouldReturn` (1, 1) + Right retained <- _runner (listSubscriptionDeadLetters subName 0) + Vector.length retained `shouldBe` 1 + + it "reports an already-processed Kiroku dead letter without appending" $ \(_storeHandle, StoreRunner _runner) -> do + let subName = SubscriptionName "counter-pm-replay-duplicate" + replayHandler recorded = + case decodeRecorded counterCodec recorded of + Left err -> pure (Left (Text.pack (show err))) + Right input -> do + outcome <- + runProcessManagerOnce + defaultRunCommandOptions + counterProcessManager + recorded + input + pure $ + case outcome of + Left err -> Left (Text.pack (show err)) + Right result -> Right (classifyProcessManagerReplay result) + source <- deadLetterCounterSource _storeHandle subName (CounterAdded 8) + Right (Right _) <- + _runner $ + runProcessManagerOnce + defaultRunCommandOptions + counterProcessManager + source + (CounterAdded 8) + countsBefore <- processManagerReplayCounts _storeHandle + + Right outcomes <- + _runner $ + replaySubscriptionDeadLetters subName 0 replayHandler + outcomes + `shouldBe` [ ReplayOutcome + { replayGlobalPosition = source ^. #globalPosition + , replayEventId = source ^. #eventId + , replayResult = ReplayedDuplicate + } + ] + processManagerReplayCounts _storeHandle `shouldReturn` countsBefore + + it "keeps multiple workflow process managers isolated by configured streams and categories" $ \(_storeHandle, StoreRunner _runner) -> do + let sourceEvent = recordedFromEventId (EventId sampleUuid) (CounterAdded 6) + fulfillmentManager = + workflowProcessManager + "fulfillment-pm" + "pm:fulfillment" + "fulfillment-target-order-1" + billingManager = + workflowProcessManager + "billing-pm" + "pm:billing" + "billing-target-order-1" + fulfillmentResult <- + _runner $ + runProcessManagerOnce defaultRunCommandOptions fulfillmentManager sourceEvent (CounterAdded 6) + billingResult <- + _runner $ + runProcessManagerOnce defaultRunCommandOptions billingManager sourceEvent (CounterAdded 6) + assertWorkflowProcessManagerAppended fulfillmentResult + assertWorkflowProcessManagerAppended billingResult + + Right fulfillmentManagerEvents <- + _runner $ + Store.readStreamForward (StreamName "pm:fulfillment-order-1") (StreamVersion 0) 10 + Right billingManagerEvents <- + _runner $ + Store.readStreamForward (StreamName "pm:billing-order-1") (StreamVersion 0) 10 + Right fulfillmentTargetEvents <- + _runner $ + Store.readStreamForward (StreamName "fulfillment-target-order-1") (StreamVersion 0) 10 + Right billingTargetEvents <- + _runner $ + Store.readStreamForward (StreamName "billing-target-order-1") (StreamVersion 0) 10 + Vector.length fulfillmentManagerEvents `shouldBe` 1 + Vector.length billingManagerEvents `shouldBe` 1 + Vector.length fulfillmentTargetEvents `shouldBe` 1 + Vector.length billingTargetEvents `shouldBe` 1 + + Right fulfillmentCategoryEvents <- + _runner $ + Store.readCategory (CategoryName "pm:fulfillment") (GlobalPosition 0) 10 + Right billingCategoryEvents <- + _runner $ + Store.readCategory (CategoryName "pm:billing") (GlobalPosition 0) 10 + Right sharedPmCategoryEvents <- + _runner $ + Store.readCategory (CategoryName "pm") (GlobalPosition 0) 10 + Right sharedPmNamespaceEvents <- + _runner $ + Store.readCategory (CategoryName "pm:") (GlobalPosition 0) 10 + Vector.length fulfillmentCategoryEvents `shouldBe` 1 + Vector.length billingCategoryEvents `shouldBe` 1 + sharedPmCategoryEvents `shouldBe` Vector.empty + sharedPmNamespaceEvents `shouldBe` Vector.empty + + it "worker finalizes AckOk through the ack handle on success" $ \(_storeHandle, StoreRunner _runner) -> do + decisionsRef <- newIORef [] + let sourceEvent = recordedFromEventId (EventId sampleUuid) (CounterAdded 9) + messages = [(sourceEvent, CounterAdded 9)] + adapter = inMemoryAdapter decisionsRef messages + Right () <- + _runner $ + runProcessManagerWorker defaultRunCommandOptions counterProcessManager adapter Just + decisions <- readIORef decisionsRef + decisions `shouldBe` [AckOk] + + it "worker halts instead of acking when a target dispatch is rejected" $ \(_storeHandle, StoreRunner _runner) -> do + decisionsRef <- newIORef [] + let sourceEvent = recordedFromEventId (EventId sampleUuid) (CounterAdded 9) + messages = [(sourceEvent, CounterAdded 9)] + adapter = inMemoryAdapter decisionsRef messages + rejectingPm = + (counterProcessManager :: ProcessManager CounterEvent (HsPred '[] CounterCommand) '[] CounterState CounterCommand CounterEvent (HsPred '[] CounterCommand) '[] CounterState CounterCommand CounterEvent) + { targetEventStream = rejectingEventStream + } + Right () <- + _runner $ + runProcessManagerWorker defaultRunCommandOptions rejectingPm adapter Just + decisions <- readIORef decisionsRef + decisions `shouldSatisfy` \case + [AckHalt (HaltFatal _)] -> True + _ -> False + Right targetEvents <- + _runner $ + Store.readStreamForward (StreamName "counter-target-order-1") (StreamVersion 0) 10 + Right managerEvents <- + _runner $ + Store.readStreamForward (StreamName "pm:counter-order-1") (StreamVersion 0) 10 + Vector.length targetEvents `shouldBe` 0 + Vector.length managerEvents `shouldBe` 1 + + it "dead-letters a rejected dispatch and continues to the next event" $ \(_storeHandle, StoreRunner _runner) -> do + (exporter, metricsRef) <- inMemoryMetricExporter + (provider, _env) <- + createMeterProvider + emptyMaterializedResources + defaultSdkMeterProviderOptions{metricExporter = Just exporter} + meter <- getMeter provider Telemetry.keiroInstrumentationLibrary + keiroMetrics <- Telemetry.newKeiroMetrics meter + decisionsRef <- newIORef [] + let first = recordedFromEventId (EventId sampleUuid) (CounterAdded 9) + second = recordedFromEventId (EventId sampleUuid2) (CounterAdded 1) + messages = [(first, CounterAdded 9), (second, CounterAdded 1)] + adapter = inMemoryAdapter decisionsRef messages + policyPm = + (counterProcessManager :: ProcessManager CounterEvent (HsPred '[] CounterCommand) '[] CounterState CounterCommand CounterEvent (HsPred '[] CounterCommand) '[] CounterState CounterCommand CounterEvent) + { targetEventStream = rejectNineEventStream + } + workerOptions = + defaultWorkerOptions + & #rejectedCommandPolicy + .~ RejectedDeadLetter + & #metrics + ?~ keiroMetrics + Right () <- + _runner $ + runProcessManagerWorkerWith workerOptions defaultRunCommandOptions policyPm adapter Just + readIORef decisionsRef `shouldReturn` [AckOk, AckOk] + Right deadLetters <- _runner (listDispatchDeadLetters "counter-pm") + case deadLetters of + [row] -> do + row ^. #dispatcherKind `shouldBe` DispatcherProcessManager + row ^. #correlationId `shouldBe` "order-1" + row ^. #sourceEventId `shouldBe` EventId sampleUuid + row ^. #emitIndex `shouldBe` 0 + row ^. #targetStreamName `shouldBe` StreamName "counter-target-order-1" + row ^. #errorClass `shouldBe` "command_rejected" + row ^. #attemptCount `shouldBe` 1 + other -> expectationFailure ("expected one rejected dispatch dead letter, got " <> show other) + Right targetEvents <- + _runner $ + Store.readStreamForward (StreamName "counter-target-order-1") (StreamVersion 0) 10 + Right managerEvents <- + _runner $ + Store.readStreamForward (StreamName "pm:counter-order-1") (StreamVersion 0) 10 + Vector.length targetEvents `shouldBe` 1 + Vector.length managerEvents `shouldBe` 2 + _ <- forceFlushMeterProvider provider Nothing + exported <- readIORef metricsRef + lookup "keiro.dispatch.deadlettered" (flattenScalarPoints exported) `shouldBe` Just (IntNumber 1) + + it "skips a rejected dispatch without writing a dead-letter row" $ \(_storeHandle, StoreRunner _runner) -> do + (exporter, metricsRef) <- inMemoryMetricExporter + (provider, _env) <- + createMeterProvider + emptyMaterializedResources + defaultSdkMeterProviderOptions{metricExporter = Just exporter} + meter <- getMeter provider Telemetry.keiroInstrumentationLibrary + keiroMetrics <- Telemetry.newKeiroMetrics meter + decisionsRef <- newIORef [] + let sourceEvent = recordedFromEventId (EventId sampleUuid) (CounterAdded 9) + adapter = inMemoryAdapter decisionsRef [(sourceEvent, CounterAdded 9)] + rejectingPm = + (counterProcessManager :: ProcessManager CounterEvent (HsPred '[] CounterCommand) '[] CounterState CounterCommand CounterEvent (HsPred '[] CounterCommand) '[] CounterState CounterCommand CounterEvent) + { targetEventStream = rejectingEventStream + } + workerOptions = + defaultWorkerOptions + & #rejectedCommandPolicy + .~ RejectedSkip + & #metrics + ?~ keiroMetrics + Right () <- + _runner $ + runProcessManagerWorkerWith workerOptions defaultRunCommandOptions rejectingPm adapter Just + readIORef decisionsRef `shouldReturn` [AckOk] + Right deadLetters <- _runner (listDispatchDeadLetters "counter-pm") + deadLetters `shouldBe` [] + _ <- forceFlushMeterProvider provider Nothing + exported <- readIORef metricsRef + lookup "keiro.dispatch.deadlettered" (flattenScalarPoints exported) `shouldBe` Just (IntNumber 1) + + it "dead-letters a manager-state rejection at emit index minus one" $ \(_storeHandle, StoreRunner _runner) -> do + decisionsRef <- newIORef [] + let sourceEvent = recordedFromEventId (EventId sampleUuid) (CounterAdded 9) + adapter = inMemoryAdapter decisionsRef [(sourceEvent, CounterAdded 9)] + rejectingManager = + (counterProcessManager :: ProcessManager CounterEvent (HsPred '[] CounterCommand) '[] CounterState CounterCommand CounterEvent (HsPred '[] CounterCommand) '[] CounterState CounterCommand CounterEvent) + { eventStream = rejectingEventStream + } + workerOptions = defaultWorkerOptions & #rejectedCommandPolicy .~ RejectedDeadLetter + Right () <- + _runner $ + runProcessManagerWorkerWith workerOptions defaultRunCommandOptions rejectingManager adapter Just + readIORef decisionsRef `shouldReturn` [AckOk] + Right deadLetters <- _runner (listDispatchDeadLetters "counter-pm") + case deadLetters of + [row] -> do + row ^. #emitIndex `shouldBe` (-1) + row ^. #targetStreamName `shouldBe` StreamName "pm:counter-order-1" + row ^. #errorClass `shouldBe` "command_rejected" + other -> expectationFailure ("expected one manager-state dead letter, got " <> show other) + Right managerEvents <- + _runner $ + Store.readStreamForward (StreamName "pm:counter-order-1") (StreamVersion 0) 10 + managerEvents `shouldBe` Vector.empty + + it "keeps rejected-dispatch dead letters idempotent on source redelivery" $ \(_storeHandle, StoreRunner _runner) -> do + decisionsRef <- newIORef [] + let sourceEvent = recordedFromEventId (EventId sampleUuid) (CounterAdded 9) + adapter = inMemoryAdapter decisionsRef [(sourceEvent, CounterAdded 9), (sourceEvent, CounterAdded 9)] + rejectingPm = + (counterProcessManager :: ProcessManager CounterEvent (HsPred '[] CounterCommand) '[] CounterState CounterCommand CounterEvent (HsPred '[] CounterCommand) '[] CounterState CounterCommand CounterEvent) + { targetEventStream = rejectingEventStream + } + workerOptions = defaultWorkerOptions & #rejectedCommandPolicy .~ RejectedDeadLetter + Right () <- + _runner $ + runProcessManagerWorkerWith workerOptions defaultRunCommandOptions rejectingPm adapter Just + readIORef decisionsRef `shouldReturn` [AckOk, AckOk] + Right deadLetters <- _runner (listDispatchDeadLetters "counter-pm") + Prelude.length deadLetters `shouldBe` 1 + + it "records dispatch failures through worker metrics" $ \(_storeHandle, StoreRunner _runner) -> do + (exporter, metricsRef) <- inMemoryMetricExporter + (provider, _env) <- + createMeterProvider + emptyMaterializedResources + defaultSdkMeterProviderOptions{metricExporter = Just exporter} + meter <- getMeter provider Telemetry.keiroInstrumentationLibrary + keiroMetrics <- Telemetry.newKeiroMetrics meter + decisionsRef <- newIORef [] + let sourceEvent = recordedFromEventId (EventId sampleUuid) (CounterAdded 9) + messages = [(sourceEvent, CounterAdded 9)] + adapter = inMemoryAdapter decisionsRef messages + rejectingPm = + (counterProcessManager :: ProcessManager CounterEvent (HsPred '[] CounterCommand) '[] CounterState CounterCommand CounterEvent (HsPred '[] CounterCommand) '[] CounterState CounterCommand CounterEvent) + { targetEventStream = rejectingEventStream + } + workerOptions = defaultWorkerOptions & #metrics ?~ keiroMetrics + Right () <- + _runner $ + runProcessManagerWorkerWith workerOptions defaultRunCommandOptions rejectingPm adapter Just + _ <- forceFlushMeterProvider provider Nothing + exported <- readIORef metricsRef + lookup "keiro.dispatch.failed" (flattenScalarPoints exported) `shouldBe` Just (IntNumber 1) + + it "classifies transient store failures as retry and deterministic command failures as halt" $ \(_storeHandle, StoreRunner _runner) -> do + isRejectionClass CommandRejected `shouldBe` True + isRejectionClass (CommandAmbiguous [0, 1]) `shouldBe` True + isRejectionClass (EncodeFailed (NonObjectCallerMetadata Aeson.Null)) `shouldBe` False + ackForCommandError (RetryDelay 5) (StoreFailed (Store.ConnectionLost "boom")) + `shouldBe` AckRetry (RetryDelay 5) + ackForCommandError (RetryDelay 5) CommandRejected `shouldSatisfy` \case + AckHalt (HaltFatal _) -> True + _ -> False + ackForCommandError (RetryDelay 5) (CommandAmbiguous [0, 1]) `shouldSatisfy` \case + AckHalt (HaltFatal _) -> True + _ -> False + + it "worker applies poison-message policy on decode failure" $ \(_storeHandle, StoreRunner _runner) -> do + let badMessages = ["not-decodable" :: Text] + defaultDecisions <- newIORef [] + Right () <- + _runner $ + runProcessManagerWorker + defaultRunCommandOptions + counterProcessManager + (inMemoryAdapter defaultDecisions badMessages) + (const Nothing) + defaultObserved <- readIORef defaultDecisions + defaultObserved `shouldSatisfy` \case + [AckHalt (HaltFatal _)] -> True + _ -> False + + skippedRef <- newIORef [] + skipDecisions <- newIORef [] + let skipOptions = + defaultWorkerOptions + & #poisonPolicy + .~ PoisonSkip (\env -> liftIO (modifyIORef' skippedRef (<> [env ^. #payload]))) + Right () <- + _runner $ + runProcessManagerWorkerWith + skipOptions + defaultRunCommandOptions + counterProcessManager + (inMemoryAdapter skipDecisions badMessages) + (const Nothing) + readIORef skipDecisions `shouldReturn` [AckOk] + readIORef skippedRef `shouldReturn` badMessages + + deadLetterDecisions <- newIORef [] + deadLetterRef <- newIORef [] + let deadLetterOptions = + defaultWorkerOptions + & #poisonPolicy + .~ PoisonDeadLetter (\env -> liftIO (modifyIORef' deadLetterRef (<> [env ^. #payload]))) + Right () <- + _runner $ + runProcessManagerWorkerWith + deadLetterOptions + defaultRunCommandOptions + counterProcessManager + (inMemoryAdapter deadLetterDecisions badMessages) + (const Nothing) + deadLetterObserved <- readIORef deadLetterDecisions + deadLetterObserved `shouldSatisfy` \case + [AckDeadLetter (InvalidPayload _)] -> True + _ -> False + readIORef deadLetterRef `shouldReturn` badMessages + + it "folds a concurrent duplicate target dispatch to PMCommandDuplicate" $ \(_storeHandle, StoreRunner _runner) -> do + insertCount <- newIORef (0 :: Int) + let sourceEvent = recordedFromEventId (EventId sampleUuid) (CounterAdded 9) + commandId = deterministicCommandId "counter-pm" "order-1" (sourceEvent ^. #eventId) 0 + targetStreamName = StreamName "counter-target-order-1" + insertConcurrentTarget = do + callNo <- atomicModifyIORef' insertCount (\n -> (n + 1, n)) + when (callNo == 1) $ appendCounterEventWithId _storeHandle targetStreamName commandId (CounterAdded 9) + options = + defaultRunCommandOptions + & #beforeAppend + .~ insertConcurrentTarget + & #retryBackoffMicros + .~ 0 + result <- + _runner $ + runProcessManagerOnce options counterProcessManager sourceEvent (CounterAdded 9) + case result of + Right (Right pmResult) -> + pmResult ^. #commandResults `shouldSatisfy` \case + [PMCommandDuplicate duplicateId] -> duplicateId == commandId + _ -> False + other -> expectationFailure ("expected duplicate target dispatch fold, got " <> show other) + Right targetEvents <- + _runner $ + Store.readStreamForward targetStreamName (StreamVersion 0) 10 + Vector.length targetEvents `shouldBe` 1 + + it "folds a concurrent duplicate manager-state append to PMStateDuplicate" $ \(_storeHandle, StoreRunner _runner) -> do + insertCount <- newIORef (0 :: Int) + let sourceEvent = recordedFromEventId (EventId sampleUuid) (CounterAdded 9) + managerId = deterministicCommandId "counter-pm" "order-1" (sourceEvent ^. #eventId) (-1) + managerStreamName = StreamName "pm:counter-order-1" + insertConcurrentManager = do + callNo <- atomicModifyIORef' insertCount (\n -> (n + 1, n)) + when (callNo == 0) $ appendCounterEventWithId _storeHandle managerStreamName managerId (CounterAdded 9) + options = + defaultRunCommandOptions + & #beforeAppend + .~ insertConcurrentManager + & #retryBackoffMicros + .~ 0 + result <- + _runner $ + runProcessManagerOnce options counterProcessManager sourceEvent (CounterAdded 9) + case result of + Right (Right pmResult) -> do + pmResult ^. #managerResult `shouldSatisfy` \case + PMStateDuplicate duplicateId -> duplicateId == managerId + _ -> False + pmResult ^. #commandResults `shouldSatisfy` \case + [PMCommandAppended{}] -> True + _ -> False + other -> expectationFailure ("expected duplicate manager-state fold, got " <> show other) + + describe "Keiro.ProcessManager duplicate confirmation" $ around (withFreshResourceStore fixture) $ do + it "rejects a duplicate report carrying a different id" $ \(_storeHandle, StoreRunner _runner) -> do + let targetStreamName = StreamName "duplicate-confirmation-mismatch" + ourId = EventId sampleUuid + otherId = EventId sampleUuid2 + appendCounterEventWithId _storeHandle targetStreamName otherId (CounterAdded 1) + outcome <- + _runner $ + confirmBenignDuplicate + targetStreamName + ourId + (StoreFailed (Store.DuplicateEvent (Just otherId))) + outcome `shouldBe` Right False + + it "rejects a matching id that exists only in another stream" $ \(_storeHandle, StoreRunner _runner) -> do + let targetStreamName = StreamName "duplicate-confirmation-target" + otherStreamName = StreamName "duplicate-confirmation-other" + ourId = EventId sampleUuid + targetEventId = EventId sampleUuid2 + appendCounterEventWithId _storeHandle targetStreamName targetEventId (CounterAdded 1) + appendCounterEventWithId _storeHandle otherStreamName ourId (CounterAdded 1) + outcome <- + _runner $ + confirmBenignDuplicate + targetStreamName + ourId + (StoreFailed (Store.DuplicateEvent (Just ourId))) + outcome `shouldBe` Right False + + it "confirms matching and id-less duplicate reports when the id is in the target stream" $ \(_storeHandle, StoreRunner _runner) -> do + let targetStreamName = StreamName "duplicate-confirmation-present" + ourId = EventId sampleUuid + appendCounterEventWithId _storeHandle targetStreamName ourId (CounterAdded 1) + matchingOutcome <- + _runner $ + confirmBenignDuplicate + targetStreamName + ourId + (StoreFailed (Store.DuplicateEvent (Just ourId))) + missingDetailOutcome <- + _runner $ + confirmBenignDuplicate + targetStreamName + ourId + (StoreFailed (Store.DuplicateEvent Nothing)) + matchingOutcome `shouldBe` Right True + missingDetailOutcome `shouldBe` Right True + + it "rejects non-duplicate command failures" $ \(_storeHandle, StoreRunner _runner) -> do + let targetStreamName = StreamName "duplicate-confirmation-non-duplicate" + ourId = EventId sampleUuid + appendCounterEventWithId _storeHandle targetStreamName ourId (CounterAdded 1) + outcome <- + _runner $ + confirmBenignDuplicate + targetStreamName + ourId + (StoreFailed (Store.ConnectionLost "boom")) + outcome `shouldBe` Right False + + describe "Keiro.ProcessManager snapshots" $ around (withFreshResourceStore fixture) $ do + it "writes a snapshot of the manager state stream after the policy threshold" $ \(_storeHandle, StoreRunner _runner) -> do + -- Two distinct source events, both correlating to "order-1", drive the one + -- manager instance to manager-stream version 2, which Every 2 snapshots. + let sourceA = recordedFromEventId (EventId sampleUuid) (CounterAdded 2) + sourceB = recordedFromEventId (EventId sampleUuid2) (CounterAdded 3) + Right (Right _) <- + _runner $ + runProcessManagerOnce defaultRunCommandOptions pmSnapshotProcessManager sourceA (CounterAdded 2) + Right (Right _) <- + _runner $ + runProcessManagerOnce defaultRunCommandOptions pmSnapshotProcessManager sourceB (CounterAdded 3) + Right managerEvents <- + _runner $ + Store.readStreamForward (StreamName "pm:counter-snap-order-1") (StreamVersion 0) 10 + Vector.length managerEvents `shouldBe` 2 + Right snapshotVersion <- + _runner $ + Store.runTransaction $ + Tx.statement "pm:counter-snap-order-1" snapshotVersionForStreamStmt + snapshotVersion `shouldBe` Just (StreamVersion 2) + + it "hydrates the manager from its snapshot and replays only the tail" $ \(_storeHandle, StoreRunner _runner) -> do + -- After the threshold snapshot exists, a third reaction should land on top of + -- the snapshot at version 3 rather than replaying from version 0. + let sourceA = recordedFromEventId (EventId sampleUuid) (CounterAdded 2) + sourceB = recordedFromEventId (EventId sampleUuid2) (CounterAdded 3) + sourceC = recordedFromEventId (EventId sampleUuid3) (CounterAdded 4) + Right (Right _) <- + _runner $ + runProcessManagerOnce defaultRunCommandOptions pmSnapshotProcessManager sourceA (CounterAdded 2) + Right (Right _) <- + _runner $ + runProcessManagerOnce defaultRunCommandOptions pmSnapshotProcessManager sourceB (CounterAdded 3) + -- Confirm the snapshot is present before the tail-replay reaction. + Right snapshotVersion <- + _runner $ + Store.runTransaction $ + Tx.statement "pm:counter-snap-order-1" snapshotVersionForStreamStmt + snapshotVersion `shouldBe` Just (StreamVersion 2) + result <- + _runner $ + runProcessManagerOnce defaultRunCommandOptions pmSnapshotProcessManager sourceC (CounterAdded 4) + case result of + Right (Right pmResult) -> + case pmResult ^. #managerResult of + PMStateAppended managerResult -> + managerResult ^. #streamVersion `shouldBe` StreamVersion 3 + other -> expectationFailure ("expected appended manager state, got " <> show other) + other -> expectationFailure ("expected snapshot-assisted PM reaction, got " <> show other) + + describe "Keiro.Router" $ around (withFreshResourceStore fixture) $ do + it "encodes colon-bearing and non-ASCII id components without collisions" $ \(_storeHandle, StoreRunner _runner) -> do + let sourceEventId = EventId sampleUuid + colonLeft = + deterministicRouterCommandId + "router:a" + "key" + sourceEventId + (StreamName "target") + 0 + colonRight = + deterministicRouterCommandId + "router" + "a:key" + sourceEventId + (StreamName "target") + 0 + unicodeLeft = + deterministicRouterCommandId + "router" + "key" + sourceEventId + (StreamName ("target-" <> Text.singleton '\x101')) + 0 + unicodeRight = + deterministicRouterCommandId + "router" + "key" + sourceEventId + (StreamName ("target-" <> Text.singleton '\x201')) + 0 + colonLeft `shouldNotBe` colonRight + unicodeLeft `shouldNotBe` unicodeRight + + it "resolves targets effectfully and fans out one command per target" $ \(_storeHandle, StoreRunner _runner) -> do + Right () <- + _runner $ + initializeRegisteredReadModel routerTargetsReadModel initializeRouterTargetsTable + Right () <- _runner $ + Store.runTransaction $ do + Tx.statement ("g1", "router-target-a") insertRouterTargetStmt + Tx.statement ("g1", "router-target-b") insertRouterTargetStmt + Tx.statement ("g1", "router-target-c") insertRouterTargetStmt + let sourceEvent = recordedFromEventId (EventId sampleUuid) (CounterAdded 1) + Right (RouterResult rs1) <- + _runner $ + runRouterOnce defaultRunCommandOptions demoRouter sourceEvent (RouteGroup "g1") + length rs1 `shouldBe` 3 + rs1 `shouldSatisfy` all isAppended + -- Data-dependence is load-bearing: an unseeded group resolves to no + -- targets, so the count tracks the read model, not a fixed list. + Right (RouterResult rsEmpty) <- + _runner $ + runRouterOnce defaultRunCommandOptions demoRouter sourceEvent (RouteGroup "no-such-group") + length rsEmpty `shouldBe` 0 + -- Each resolved target stream received exactly one command. + Right targetA <- + _runner $ + Store.readStreamForward (StreamName "router-target-a") (StreamVersion 0) 10 + Right targetB <- + _runner $ + Store.readStreamForward (StreamName "router-target-b") (StreamVersion 0) 10 + Right targetC <- + _runner $ + Store.readStreamForward (StreamName "router-target-c") (StreamVersion 0) 10 + Vector.length targetA `shouldBe` 1 + Vector.length targetB `shouldBe` 1 + Vector.length targetC `shouldBe` 1 + + it "reports every dispatch as a duplicate on replay, writing no new events" $ \(_storeHandle, StoreRunner _runner) -> do + Right () <- + _runner $ + initializeRegisteredReadModel routerTargetsReadModel initializeRouterTargetsTable + Right () <- _runner $ + Store.runTransaction $ do + Tx.statement ("g1", "router-target-a") insertRouterTargetStmt + Tx.statement ("g1", "router-target-b") insertRouterTargetStmt + Tx.statement ("g1", "router-target-c") insertRouterTargetStmt + let sourceEvent = recordedFromEventId (EventId sampleUuid) (CounterAdded 1) + Right (RouterResult rs1) <- + _runner $ + runRouterOnce defaultRunCommandOptions demoRouter sourceEvent (RouteGroup "g1") + rs1 `shouldSatisfy` all isAppended + Right (RouterResult rs2) <- + _runner $ + runRouterOnce defaultRunCommandOptions demoRouter sourceEvent (RouteGroup "g1") + length rs2 `shouldBe` 3 + rs2 `shouldSatisfy` all isDuplicate + -- Replay added nothing: each target stream still holds exactly one event. + Right targetA <- + _runner $ + Store.readStreamForward (StreamName "router-target-a") (StreamVersion 0) 10 + Right targetB <- + _runner $ + Store.readStreamForward (StreamName "router-target-b") (StreamVersion 0) 10 + Right targetC <- + _runner $ + Store.readStreamForward (StreamName "router-target-c") (StreamVersion 0) 10 + Vector.length targetA `shouldBe` 1 + Vector.length targetB `shouldBe` 1 + Vector.length targetC `shouldBe` 1 + + it "dedups by target identity when a redelivered resolve reorders targets after a partial dispatch" $ \(_storeHandle, StoreRunner _runner) -> do + attemptsRef <- newIORef (0 :: Int) + let sourceEvent = recordedFromEventId (EventId sampleUuid) (CounterAdded 1) + router = unstableRouter attemptsRef $ \case + 0 -> ["swap-a"] + _ -> ["swap-b", "swap-a"] + Right (RouterResult firstAttempt) <- + _runner $ + runRouterOnce defaultRunCommandOptions router sourceEvent (RouteGroup "g1") + firstAttempt `shouldSatisfy` all isAppended + Right (RouterResult secondAttempt) <- + _runner $ + runRouterOnce defaultRunCommandOptions router sourceEvent (RouteGroup "g1") + secondAttempt `shouldSatisfy` \case + [swapB, swapA] -> isAppended swapB && isDuplicate swapA + _ -> False + Right swapAEvents <- + _runner $ + Store.readStreamForward (StreamName "swap-a") (StreamVersion 0) 10 + Right swapBEvents <- + _runner $ + Store.readStreamForward (StreamName "swap-b") (StreamVersion 0) 10 + Vector.length swapAEvents `shouldBe` 1 + Vector.length swapBEvents `shouldBe` 1 + + it "dispatches a target added by resolve drift instead of misreading it as a duplicate" $ \(_storeHandle, StoreRunner _runner) -> do + attemptsRef <- newIORef (0 :: Int) + let sourceEvent = recordedFromEventId (EventId sampleUuid) (CounterAdded 1) + router = unstableRouter attemptsRef $ \case + 0 -> ["growth-a", "growth-b"] + _ -> ["growth-a", "growth-c"] + Right (RouterResult firstAttempt) <- + _runner $ + runRouterOnce defaultRunCommandOptions router sourceEvent (RouteGroup "g1") + firstAttempt `shouldSatisfy` all isAppended + Right (RouterResult secondAttempt) <- + _runner $ + runRouterOnce defaultRunCommandOptions router sourceEvent (RouteGroup "g1") + secondAttempt `shouldSatisfy` \case + [growthA, growthC] -> isDuplicate growthA && isAppended growthC + _ -> False + Right growthAEvents <- + _runner $ + Store.readStreamForward (StreamName "growth-a") (StreamVersion 0) 10 + Right growthBEvents <- + _runner $ + Store.readStreamForward (StreamName "growth-b") (StreamVersion 0) 10 + Right growthCEvents <- + _runner $ + Store.readStreamForward (StreamName "growth-c") (StreamVersion 0) 10 + Vector.length growthAEvents `shouldBe` 1 + Vector.length growthBEvents `shouldBe` 1 + Vector.length growthCEvents `shouldBe` 1 + + it "keeps full-completion order swaps idempotent" $ \(_storeHandle, StoreRunner _runner) -> do + attemptsRef <- newIORef (0 :: Int) + let sourceEvent = recordedFromEventId (EventId sampleUuid) (CounterAdded 1) + router = unstableRouter attemptsRef $ \case + 0 -> ["order-a", "order-b"] + _ -> ["order-b", "order-a"] + Right (RouterResult firstAttempt) <- + _runner $ + runRouterOnce defaultRunCommandOptions router sourceEvent (RouteGroup "g1") + firstAttempt `shouldSatisfy` all isAppended + Right (RouterResult secondAttempt) <- + _runner $ + runRouterOnce defaultRunCommandOptions router sourceEvent (RouteGroup "g1") + secondAttempt `shouldSatisfy` all isDuplicate + Right orderAEvents <- + _runner $ + Store.readStreamForward (StreamName "order-a") (StreamVersion 0) 10 + Right orderBEvents <- + _runner $ + Store.readStreamForward (StreamName "order-b") (StreamVersion 0) 10 + Vector.length orderAEvents `shouldBe` 1 + Vector.length orderBEvents `shouldBe` 1 + + it "keeps dispatches to targets dropped by a later resolve attempt" $ \(_storeHandle, StoreRunner _runner) -> do + attemptsRef <- newIORef (0 :: Int) + let sourceEvent = recordedFromEventId (EventId sampleUuid) (CounterAdded 1) + router = unstableRouter attemptsRef $ \case + 0 -> ["drop-a", "drop-b"] + _ -> ["drop-b"] + Right (RouterResult firstAttempt) <- + _runner $ + runRouterOnce defaultRunCommandOptions router sourceEvent (RouteGroup "g1") + firstAttempt `shouldSatisfy` all isAppended + Right (RouterResult secondAttempt) <- + _runner $ + runRouterOnce defaultRunCommandOptions router sourceEvent (RouteGroup "g1") + secondAttempt `shouldSatisfy` \case + [dropB] -> isDuplicate dropB + _ -> False + -- Resolve is authoritative per attempt. Across redeliveries, the + -- dispatched set is the union of each attempt's resolved targets. + Right dropAEvents <- + _runner $ + Store.readStreamForward (StreamName "drop-a") (StreamVersion 0) 10 + Right dropBEvents <- + _runner $ + Store.readStreamForward (StreamName "drop-b") (StreamVersion 0) 10 + Vector.length dropAEvents `shouldBe` 1 + Vector.length dropBEvents `shouldBe` 1 + + it "keeps repeated commands to one target distinct within a resolve batch" $ \(_storeHandle, StoreRunner _runner) -> do + attemptsRef <- newIORef (0 :: Int) + let sourceEvent = recordedFromEventId (EventId sampleUuid) (CounterAdded 1) + router = unstableRouter attemptsRef (const ["twin", "twin"]) + Right (RouterResult firstAttempt) <- + _runner $ + runRouterOnce defaultRunCommandOptions router sourceEvent (RouteGroup "g1") + firstAttempt `shouldSatisfy` all isAppended + Right twinEventsAfterFirstAttempt <- + _runner $ + Store.readStreamForward (StreamName "twin") (StreamVersion 0) 10 + Vector.length twinEventsAfterFirstAttempt `shouldBe` 2 + Right (RouterResult secondAttempt) <- + _runner $ + runRouterOnce defaultRunCommandOptions router sourceEvent (RouteGroup "g1") + secondAttempt `shouldSatisfy` all isDuplicate + Right twinEventsAfterSecondAttempt <- + _runner $ + Store.readStreamForward (StreamName "twin") (StreamVersion 0) 10 + Vector.length twinEventsAfterSecondAttempt `shouldBe` 2 + + it "drains an adapter, dispatching one command per resolved target for every message" $ \(_storeHandle, StoreRunner _runner) -> do + Right () <- + _runner $ + initializeRegisteredReadModel routerTargetsReadModel initializeRouterTargetsTable + Right () <- _runner $ + Store.runTransaction $ do + Tx.statement ("g1", "worker-a") insertRouterTargetStmt + Tx.statement ("g1", "worker-b") insertRouterTargetStmt + Tx.statement ("g2", "worker-c") insertRouterTargetStmt + decisionsRef <- newIORef [] + let sourceEvent1 = recordedFromEventId (EventId sampleUuid) (CounterAdded 1) + sourceEvent2 = recordedFromEventId (EventId sampleUuid2) (CounterAdded 1) + messages = + [ (sourceEvent1, RouteGroup "g1") + , (sourceEvent2, RouteGroup "g2") + ] + adapter = inMemoryAdapter decisionsRef messages + Right () <- + _runner $ + runRouterWorker defaultRunCommandOptions demoRouter adapter Just + decisions <- readIORef decisionsRef + decisions `shouldBe` [AckOk, AckOk] + Right wa <- + _runner $ + Store.readStreamForward (StreamName "worker-a") (StreamVersion 0) 10 + Right wb <- + _runner $ + Store.readStreamForward (StreamName "worker-b") (StreamVersion 0) 10 + Right wc <- + _runner $ + Store.readStreamForward (StreamName "worker-c") (StreamVersion 0) 10 + Vector.length wa `shouldBe` 1 + Vector.length wb `shouldBe` 1 + Vector.length wc `shouldBe` 1 + + it "finalizes AckHalt rather than AckOk when a dispatched command fails" $ \(_storeHandle, StoreRunner _runner) -> do + decisionsRef <- newIORef [] + let sourceEvent = recordedFromEventId (EventId sampleUuid) (CounterAdded 1) + messages = [(sourceEvent, RouteGroup "g1")] + adapter = inMemoryAdapter decisionsRef messages + Right () <- + _runner $ + runRouterWorker defaultRunCommandOptions failingRouter adapter Just + decisions <- readIORef decisionsRef + decisions `shouldSatisfy` \case + [AckHalt (HaltFatal _)] -> True + _ -> False + + it "dead-letters a rejected router dispatch and acknowledges the source event" $ \(_storeHandle, StoreRunner _runner) -> do + decisionsRef <- newIORef [] + let sourceEvent = recordedFromEventId (EventId sampleUuid) (CounterAdded 1) + adapter = inMemoryAdapter decisionsRef [(sourceEvent, RouteGroup "g1")] + workerOptions = defaultWorkerOptions & #rejectedCommandPolicy .~ RejectedDeadLetter + Right () <- + _runner $ + runRouterWorkerWith workerOptions defaultRunCommandOptions failingRouter adapter Just + readIORef decisionsRef `shouldReturn` [AckOk] + Right deadLetters <- _runner (listDispatchDeadLetters "failing-router") + case deadLetters of + [row] -> do + row ^. #dispatcherKind `shouldBe` DispatcherRouter + row ^. #correlationId `shouldBe` "g1" + row ^. #targetStreamName `shouldBe` StreamName "failing-target" + row ^. #errorClass `shouldBe` "command_rejected" + other -> expectationFailure ("expected one router dead letter, got " <> show other) + + it "finalizes AckRetry for a transient thrown resolver error and continues" $ \(_storeHandle, StoreRunner _runner) -> do + Right () <- + _runner $ + initializeRegisteredReadModel routerTargetsReadModel initializeRouterTargetsTable + Right () <- + _runner $ + Store.runTransaction (Tx.statement ("g2", "worker-after-retry") insertRouterTargetStmt) + decisionsRef <- newIORef [] + attemptsRef <- newIORef (0 :: Int) + let sourceEvent1 = recordedFromEventId (EventId sampleUuid) (CounterAdded 1) + sourceEvent2 = recordedFromEventId (EventId sampleUuid2) (CounterAdded 1) + messages = [(sourceEvent1, RouteGroup "g1"), (sourceEvent2, RouteGroup "g2")] + adapter = inMemoryAdapter decisionsRef messages + flakyRouter :: + (IOE :> es, Store :> es, Error Store.StoreError :> es) => + Router RouteGroup (HsPred '[] CounterCommand) '[] CounterState CounterCommand CounterEvent es + flakyRouter = + Router + { name = "flaky-router" + , key = \(RouteGroup g) -> g + , resolve = \(RouteGroup g) -> do + attempt <- liftIO (atomicModifyIORef' attemptsRef (\n -> (n + 1, n))) + if attempt == 0 + then throwError (Store.ConnectionLost "injected") + else do + result <- runQuery Nothing routerTargetsReadModel g + pure $ case result of + Right targetIds -> + [ PMCommand{target = stream targetId, command = Add 1} + | targetId <- targetIds + ] + Left _ -> [] + , targetEventStream = counterEventStream + , targetProjections = const [] + } + Right () <- + _runner $ + runRouterWorker defaultRunCommandOptions flakyRouter adapter Just + decisions <- readIORef decisionsRef + decisions `shouldSatisfy` \case + [AckRetry{}, AckOk] -> True + _ -> False + + it "finalizes AckHalt for a deterministic thrown resolver error" $ \(_storeHandle, StoreRunner _runner) -> do + decisionsRef <- newIORef [] + let sourceEvent = recordedFromEventId (EventId sampleUuid) (CounterAdded 1) + messages = [(sourceEvent, RouteGroup "g1")] + adapter = inMemoryAdapter decisionsRef messages + failingResolveRouter :: + (Error Store.StoreError :> es) => + Router RouteGroup (HsPred '[] CounterCommand) '[] CounterState CounterCommand CounterEvent es + failingResolveRouter = + Router + { name = "failing-resolve-router" + , key = \(RouteGroup g) -> g + , resolve = \_ -> throwError (Store.UnexpectedServerError "XX000" "boom") + , targetEventStream = counterEventStream + , targetProjections = const [] + } + Right () <- + _runner $ + runRouterWorker defaultRunCommandOptions failingResolveRouter adapter Just + decisions <- readIORef decisionsRef + decisions `shouldSatisfy` \case + [AckHalt (HaltFatal _)] -> True + _ -> False + + it "folds a concurrent duplicate router dispatch to PMCommandDuplicate" $ \(_storeHandle, StoreRunner _runner) -> do + Right () <- + _runner $ + initializeRegisteredReadModel routerTargetsReadModel initializeRouterTargetsTable + Right () <- + _runner $ + Store.runTransaction (Tx.statement ("g1", "router-duplicate-target") insertRouterTargetStmt) + insertCount <- newIORef (0 :: Int) + let sourceEvent = recordedFromEventId (EventId sampleUuid) (CounterAdded 1) + targetStreamName = StreamName "router-duplicate-target" + commandId = + deterministicRouterCommandId + "demo-router" + "g1" + (sourceEvent ^. #eventId) + targetStreamName + 0 + insertConcurrentTarget = do + callNo <- atomicModifyIORef' insertCount (\n -> (n + 1, n)) + when (callNo == 0) $ appendCounterEventWithId _storeHandle targetStreamName commandId (CounterAdded 1) + options = + defaultRunCommandOptions + & #beforeAppend + .~ insertConcurrentTarget + & #retryBackoffMicros + .~ 0 + result <- + _runner $ + runRouterOnce options demoRouter sourceEvent (RouteGroup "g1") + case result of + Right (RouterResult [PMCommandDuplicate duplicateId]) -> + duplicateId `shouldBe` commandId + other -> expectationFailure ("expected duplicate router dispatch fold, got " <> show other) + Right targetEvents <- + _runner $ + Store.readStreamForward targetStreamName (StreamVersion 0) 10 + Vector.length targetEvents `shouldBe` 1 + + it "dedups a pre-upgrade positional router dispatch during the transition" $ \(_storeHandle, StoreRunner _runner) -> do + Right () <- + _runner $ + initializeRegisteredReadModel routerTargetsReadModel initializeRouterTargetsTable + Right () <- + _runner $ + Store.runTransaction (Tx.statement ("g1", "transition-target") insertRouterTargetStmt) + let sourceEvent = recordedFromEventId (EventId sampleUuid) (CounterAdded 1) + legacyId = deterministicCommandId "demo-router" "g1" (sourceEvent ^. #eventId) 0 + targetStreamName = StreamName "transition-target" + appendCounterEventWithId _storeHandle targetStreamName legacyId (CounterAdded 1) + result <- + _runner $ + runRouterOnce defaultRunCommandOptions demoRouter sourceEvent (RouteGroup "g1") + case result of + Right (RouterResult [PMCommandDuplicate duplicateId]) -> + duplicateId `shouldBe` legacyId + other -> expectationFailure ("expected transition duplicate, got " <> show other) + Right targetEvents <- + _runner $ + Store.readStreamForward targetStreamName (StreamVersion 0) 10 + Vector.length targetEvents `shouldBe` 1 + + describe "Keiro.Timer" $ around (withFreshStore fixture) $ do + it "validates worker options before startup" $ \_storeHandle -> do + shouldBeRight_ (mkTimerWorkerOptions defaultTimerWorkerOptions) + mkTimerWorkerOptions (defaultTimerWorkerOptions & #maxAttempts ?~ (-1)) + `shouldBeLeft` InvalidTimerMaxAttempts (-1) + mkTimerWorkerOptions (defaultTimerWorkerOptions & #requeueStuckAfter ?~ 0) + `shouldBeLeft` InvalidTimerRequeueStuckAfter 0 + + it "claims a due timer, fires a command, and marks it complete once" $ \storeHandle -> do + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + scheduleTimerTx counterTimerRequest + let firedEventId = EventId sampleUuid2 + workerResult <- Store.runStoreIO storeHandle $ + runTimerWorker Nothing dueTimerTime $ \_ -> do + fired <- + runCommand + (defaultRunCommandOptions & #eventIds .~ [firedEventId]) + counterEventStream + (stream "timer-target") + (Add 11) + case fired of + Right _ -> pure (Just firedEventId) + Left err -> liftIO (expectationFailure ("expected timer command to fire, got " <> show err)) *> pure Nothing + case workerResult of + Right (Just timer) -> + timer ^. #status `shouldBe` Firing + other -> expectationFailure ("expected fired timer, got " <> show other) + secondWorkerResult <- + Store.runStoreIO storeHandle $ + runTimerWorker Nothing dueTimerTime (\_ -> pure (Just firedEventId)) + secondWorkerResult `shouldBe` Right Nothing + Right targetEvents <- + Store.runStoreIO storeHandle $ + Store.readStreamForward (StreamName "timer-target") (StreamVersion 0) 10 + fmap (^. #eventId) (Vector.toList targetEvents) `shouldBe` [firedEventId] + + it "records timer backlog, fire lag, attempts, and stuck count" $ \storeHandle -> do + (exporter, metricsRef) <- inMemoryMetricExporter + (provider, _env) <- + createMeterProvider + emptyMaterializedResources + defaultSdkMeterProviderOptions{metricExporter = Just exporter} + meter <- getMeter provider Telemetry.keiroInstrumentationLibrary + keiroMetrics <- Telemetry.newKeiroMetrics meter + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + scheduleTimerTx counterTimerRequest + let firedEventId = EventId sampleUuid2 + workerResult <- + Store.runStoreIO storeHandle $ + runTimerWorker (Just keiroMetrics) dueTimerTime (\_ -> pure (Just firedEventId)) + case workerResult of + Right (Just _) -> pure () + other -> expectationFailure ("expected a fired timer, got " <> show other) + _ <- forceFlushMeterProvider provider Nothing + exported <- readIORef metricsRef + let scalars = flattenScalarPoints exported + hists = flattenHistogramPoints exported + -- One scheduled+due row at the start of the pass: backlog gauge holds 1. + lookup "keiro.timer.backlog" scalars `shouldBe` Just (IntNumber 1) + -- Nothing was stranded in 'firing' before this pass: stuck gauge holds 0. + lookup "keiro.timer.stuck" scalars `shouldBe` Just (IntNumber 0) + -- The claimed timer was due exactly at 'now' and is on its first attempt: + -- one fire.lag observation of 0 ms and one attempts observation of 1. + [(c, s) | (n, c, s) <- hists, n == "keiro.timer.fire.lag"] `shouldBe` [(1, 0.0)] + [(c, s) | (n, c, s) <- hists, n == "keiro.timer.attempts"] `shouldBe` [(1, 1.0)] + + it "finds a firing timer with findStuckTimers and requeues it for re-firing" $ \storeHandle -> do + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + scheduleTimerTx counterTimerRequest + -- Strand it in Firing by claiming without firing. + claimed <- Store.runStoreIO storeHandle $ claimDueTimer dueTimerTime + case claimed of + Right (Just timer) -> timer ^. #status `shouldBe` Firing + other -> expectationFailure ("expected a claimed timer, got " <> show other) + -- It surfaces as stuck under the permissive filter. + Right stuck <- + Store.runStoreIO storeHandle $ + findStuckTimers dueTimerTime anyStuckTimer + fmap (^. #timerId) stuck `shouldBe` [counterTimerRequest ^. #timerId] + -- A bound it does not meet (only one attempt) excludes it. + Right unmatched <- + Store.runStoreIO storeHandle $ + findStuckTimers dueTimerTime (StuckTimerFilter Nothing (Just 5)) + unmatched `shouldBe` [] + -- Requeue is idempotent: True the first time, False once it is scheduled. + requeued <- + Store.runStoreIO storeHandle $ + requeueStuckTimer (counterTimerRequest ^. #timerId) + requeued `shouldBe` Right True + requeuedAgain <- + Store.runStoreIO storeHandle $ + requeueStuckTimer (counterTimerRequest ^. #timerId) + requeuedAgain `shouldBe` Right False + -- The ordinary loop re-claims and fires it exactly once. + let firedEventId = EventId sampleUuid2 + workerResult <- Store.runStoreIO storeHandle $ + runTimerWorker Nothing dueTimerTime $ \_ -> do + fired <- + runCommand + (defaultRunCommandOptions & #eventIds .~ [firedEventId]) + counterEventStream + (stream "timer-target") + (Add 7) + case fired of + Right _ -> pure (Just firedEventId) + Left err -> liftIO (expectationFailure ("expected timer command to fire, got " <> show err)) *> pure Nothing + case workerResult of + Right (Just timer) -> + timer ^. #status `shouldBe` Firing + other -> expectationFailure ("expected re-fired timer, got " <> show other) + secondWorkerResult <- + Store.runStoreIO storeHandle $ + runTimerWorker Nothing dueTimerTime (\_ -> pure (Just firedEventId)) + secondWorkerResult `shouldBe` Right Nothing + Right targetEvents <- + Store.runStoreIO storeHandle $ + Store.readStreamForward (StreamName "timer-target") (StreamVersion 0) 10 + fmap (^. #eventId) (Vector.toList targetEvents) `shouldBe` [firedEventId] + + it "re-fires a timer stranded by a crashed worker" $ \storeHandle -> do + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + scheduleTimerTx counterTimerRequest + Right (Just claimed) <- Store.runStoreIO storeHandle $ claimDueTimer dueTimerTime + claimed ^. #status `shouldBe` Firing + realNow <- getCurrentTime + firedRef <- newIORef [] + let futureNow = addUTCTime 400 realNow + firedEventId = EventId sampleUuid2 + workerResult <- + Store.runStoreIO storeHandle $ + runTimerWorker Nothing futureNow $ \timer -> do + liftIO (modifyIORef' firedRef (<> [timer ^. #timerId])) + pure (Just firedEventId) + case workerResult of + Right (Just timer) -> timer ^. #timerId `shouldBe` counterTimerRequest ^. #timerId + other -> expectationFailure ("expected stale timer to be requeued and claimed, got " <> show other) + firedTimers <- readIORef firedRef + firedTimers `shouldBe` [counterTimerRequest ^. #timerId] + Right statusRow <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + Tx.statement sampleUuid timerStatusAndErrorStmt + statusRow `shouldBe` Just ("fired", Nothing) + secondWorkerResult <- + Store.runStoreIO storeHandle $ + runTimerWorker Nothing futureNow (\_ -> pure (Just firedEventId)) + secondWorkerResult `shouldBe` Right Nothing + + it "does not requeue a fresh firing row" $ \storeHandle -> do + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + scheduleTimerTx counterTimerRequest + Right (Just _) <- Store.runStoreIO storeHandle $ claimDueTimer dueTimerTime + realNow <- getCurrentTime + firedRef <- newIORef False + workerResult <- + Store.runStoreIO storeHandle $ + runTimerWorker Nothing realNow $ \_ -> do + liftIO (writeIORef firedRef True) + pure (Just (EventId sampleUuid2)) + workerResult `shouldBe` Right Nothing + didFire <- readIORef firedRef + didFire `shouldBe` False + Right statusRow <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + Tx.statement sampleUuid timerStatusAndErrorStmt + statusRow `shouldBe` Just ("firing", Nothing) + + it "requeueStuckAfter = Nothing preserves a stranded firing row" $ \storeHandle -> do + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + scheduleTimerTx counterTimerRequest + Right (Just _) <- Store.runStoreIO storeHandle $ claimDueTimer dueTimerTime + realNow <- getCurrentTime + firedRef <- newIORef False + let opts = defaultTimerWorkerOptions & #requeueStuckAfter .~ Nothing + workerResult <- + Store.runStoreIO storeHandle $ + runTimerWorkerWith Nothing opts (addUTCTime 400 realNow) $ \_ -> do + liftIO (writeIORef firedRef True) + pure (Just (EventId sampleUuid2)) + workerResult `shouldBe` Right Nothing + didFire <- readIORef firedRef + didFire `shouldBe` False + Right statusRow <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + Tx.statement sampleUuid timerStatusAndErrorStmt + statusRow `shouldBe` Just ("firing", Nothing) + + it "does not claim a cancelled timer" $ \storeHandle -> do + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + scheduleTimerTx counterTimerRequest + cancelled <- + Store.runStoreIO storeHandle $ + cancelTimer (counterTimerRequest ^. #timerId) + cancelled `shouldBe` Right True + claimed <- Store.runStoreIO storeHandle $ claimDueTimer dueTimerTime + claimed `shouldBe` Right Nothing + cancelledAgain <- + Store.runStoreIO storeHandle $ + cancelTimer (counterTimerRequest ^. #timerId) + cancelledAgain `shouldBe` Right False + + it "dead-letters a timer that exceeds the attempt ceiling and never reclaims it" $ \storeHandle -> do + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + scheduleTimerTx counterTimerRequest + firedRef <- newIORef False + let firedEventId = EventId sampleUuid2 + -- maxAttempts = Just 0: the first claim sets attempts = 1 > 0, so the + -- worker dead-letters instead of firing. + result <- Store.runStoreIO storeHandle $ + runTimerWorkerWith Nothing (defaultTimerWorkerOptions & #maxAttempts .~ Just 0) dueTimerTime $ \_ -> do + liftIO (writeIORef firedRef True) + pure (Just firedEventId) + case result of + Right (Just timer) -> + timer ^. #status `shouldBe` Firing + other -> expectationFailure ("expected a claimed timer, got " <> show other) + -- The fire action never ran. + didFire <- readIORef firedRef + didFire `shouldBe` False + -- The row landed in 'dead' with the expected reason in last_error. + Right statusRow <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + Tx.statement sampleUuid timerStatusAndErrorStmt + statusRow `shouldBe` Just ("dead", Just "timer exceeded attempt ceiling of 0") + -- A dead row is never re-claimed. + secondWorkerResult <- + Store.runStoreIO storeHandle $ + runTimerWorker Nothing dueTimerTime (\_ -> pure (Just firedEventId)) + secondWorkerResult `shouldBe` Right Nothing + + it "markTimerFired does not resurrect a dead timer" $ \storeHandle -> do + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + scheduleTimerTx counterTimerRequest + Right (Just _) <- Store.runStoreIO storeHandle $ claimDueTimer dueTimerTime + deadened <- + Store.runStoreIO storeHandle $ + deadLetterTimer (counterTimerRequest ^. #timerId) "operator dead-letter" + deadened `shouldBe` Right True + marked <- + Store.runStoreIO storeHandle $ + markTimerFired (counterTimerRequest ^. #timerId) (EventId sampleUuid2) + marked `shouldBe` Right False + Right statusRow <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + Tx.statement sampleUuid timerStatusAndErrorStmt + statusRow `shouldBe` Just ("dead", Just "operator dead-letter") + + it "records a row stranded in Firing in the stuck gauge" $ \storeHandle -> do + (exporter, metricsRef) <- inMemoryMetricExporter + (provider, _env) <- + createMeterProvider + emptyMaterializedResources + defaultSdkMeterProviderOptions{metricExporter = Just exporter} + meter <- getMeter provider Telemetry.keiroInstrumentationLibrary + keiroMetrics <- Telemetry.newKeiroMetrics meter + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + scheduleTimerTx counterTimerRequest + -- Strand it in Firing by claiming without firing (a crashed worker). + Right (Just _) <- Store.runStoreIO storeHandle $ claimDueTimer dueTimerTime + -- A later pass finds nothing scheduled and due, but sees the stranded row. + workerResult <- + Store.runStoreIO storeHandle $ + runTimerWorker (Just keiroMetrics) dueTimerTime (\_ -> pure Nothing) + workerResult `shouldBe` Right Nothing + _ <- forceFlushMeterProvider provider Nothing + exported <- readIORef metricsRef + let scalars = flattenScalarPoints exported + -- The one firing row is counted as stuck. + lookup "keiro.timer.stuck" scalars `shouldBe` Just (IntNumber 1) + -- It is not 'scheduled', so it does not show up as backlog. + lookup "keiro.timer.backlog" scalars `shouldBe` Just (IntNumber 0) + + describe "Keiro.Outbox.Kafka" $ do + it "converts an outbox row to a Kafka producer record" $ do + let envelope = sampleIntegrationEnvelope + row = sampleOutboxRow envelope + record = OutboxKafka.outboxRowToKafkaRecord row + record ^. #topic `shouldBe` envelope ^. #destination + record ^. #key `shouldBe` Just "order-123" + record ^. #payload `shouldBe` envelope ^. #payloadBytes + -- Headers include identity fields and content type. + let headers = record ^. #headers + messageIdHeader = Prelude.lookup "keiro-message-id" headers + messageIdHeader `shouldBe` Just "018f0f18-17aa-7000-8000-0000000000aa" + + it "drops the partition key when the envelope has no key" $ do + let envelope = sampleIntegrationEnvelope & #key .~ Nothing + record = OutboxKafka.integrationEventToKafkaRecord envelope + record ^. #key `shouldBe` Nothing + + describe "Keiro.Outbox" $ around (withFreshStore fixture) $ do + it "validates publisher options before startup" $ \_storeHandle -> do + shouldBeRight_ (mkOutboxPublishOptions defaultPublishOptions) + mkOutboxPublishOptions (defaultPublishOptions & #batchSize .~ 0) + `shouldBeLeft` InvalidOutboxBatchSize 0 + mkOutboxPublishOptions (defaultPublishOptions & #maxAttempts .~ 0) + `shouldBeLeft` InvalidOutboxMaxAttempts 0 + mkOutboxPublishOptions (defaultPublishOptions & #publishingTimeout .~ 0) + `shouldBeLeft` InvalidOutboxPublishingTimeout 0 + mkOutboxPublishOptions (defaultPublishOptions & #backoff .~ ConstantBackoff (-1)) + `shouldBeLeft` InvalidConstantBackoff (-1) + mkOutboxPublishOptions + ( defaultPublishOptions + & #backoff + .~ ExponentialBackoff + ExponentialBackoffOptions + { initial = 0 + , maxDelay = 1 + , multiplier = 2 + } + ) + `shouldBeLeft` InvalidExponentialBackoffInitial 0 + mkOutboxPublishOptions + ( defaultPublishOptions + & #backoff + .~ ExponentialBackoff + ExponentialBackoffOptions + { initial = 1 + , maxDelay = 10 + , multiplier = 0.5 + } + ) + `shouldBeLeft` InvalidExponentialBackoffMultiplier 0.5 + mkOutboxPublishOptions + ( defaultPublishOptions + & #backoff + .~ ExponentialBackoff + ExponentialBackoffOptions + { initial = 5 + , maxDelay = 4 + , multiplier = 2 + } + ) + `shouldBeLeft` InvalidExponentialBackoffMaxDelay 5 4 + + it "enqueues and looks up an outbox row" $ \storeHandle -> do + let envelope = sampleIntegrationEnvelope + oid = OutboxId outboxUuid1 + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction (enqueueIntegrationEventTx oid envelope) + lookedUp <- Store.runStoreIO storeHandle (lookupOutbox oid) + case lookedUp of + Right (Just row) -> do + row ^. #outboxId `shouldBe` oid + row ^. #status `shouldBe` OutboxPending + row ^. #attemptCount `shouldBe` 0 + row ^. #event . #messageId `shouldBe` envelope ^. #messageId + row ^. #event . #destination `shouldBe` envelope ^. #destination + row ^. #event . #payloadBytes `shouldBe` envelope ^. #payloadBytes + other -> expectationFailure ("expected enqueued row, got " <> show other) + + it "claims a pending row, transitions it to publishing, and increments attempt count" $ \storeHandle -> do + let oid = OutboxId outboxUuid1 + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction (enqueueIntegrationEventTx oid sampleIntegrationEnvelope) + now <- getCurrentTime + Right rows <- Store.runStoreIO storeHandle (claimOutboxBatch PerKeyHeadOfLine 10 now) + case rows of + [row] -> do + row ^. #outboxId `shouldBe` oid + row ^. #status `shouldBe` OutboxPublishing + row ^. #attemptCount `shouldBe` 1 + other -> expectationFailure ("expected one claimed row, got " <> show other) + + it "claims contiguous per-key runs in one pass" $ \storeHandle -> do + let keyedRows = + [ (outboxIdFromOrdinal 1, sampleIntegrationEnvelope & #messageId .~ "run-a1" & #key .~ Just "A") + , (outboxIdFromOrdinal 2, sampleIntegrationEnvelope & #messageId .~ "run-a2" & #key .~ Just "A") + , (outboxIdFromOrdinal 3, sampleIntegrationEnvelope & #messageId .~ "run-a3" & #key .~ Just "A") + , (outboxIdFromOrdinal 4, sampleIntegrationEnvelope & #messageId .~ "run-a4" & #key .~ Just "A") + , (outboxIdFromOrdinal 5, sampleIntegrationEnvelope & #messageId .~ "run-a5" & #key .~ Just "A") + , (outboxIdFromOrdinal 6, sampleIntegrationEnvelope & #messageId .~ "run-b1" & #key .~ Just "B") + , (outboxIdFromOrdinal 7, sampleIntegrationEnvelope & #messageId .~ "run-b2" & #key .~ Just "B") + , (outboxIdFromOrdinal 8, sampleIntegrationEnvelope & #messageId .~ "run-b3" & #key .~ Just "B") + ] + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + traverse_ (uncurry enqueueIntegrationEventTx) keyedRows + now <- getCurrentTime + Right rows <- Store.runStoreIO storeHandle (claimOutboxBatch PerKeyHeadOfLine 10 now) + fmap (^. #outboxId) rows `shouldBe` fmap fst keyedRows + fmap (^. #attemptCount) rows `shouldBe` replicate 8 1 + + it "does not let a backoff head starve other keys" $ \storeHandle -> do + let a1Id = outboxIdFromOrdinal 1 + a2Id = outboxIdFromOrdinal 2 + b1Id = outboxIdFromOrdinal 3 + b2Id = outboxIdFromOrdinal 4 + rows = + [ (a1Id, sampleIntegrationEnvelope & #messageId .~ "backoff-a1" & #key .~ Just "A") + , (a2Id, sampleIntegrationEnvelope & #messageId .~ "backoff-a2" & #key .~ Just "A") + , (b1Id, sampleIntegrationEnvelope & #messageId .~ "backoff-b1" & #key .~ Just "B") + , (b2Id, sampleIntegrationEnvelope & #messageId .~ "backoff-b2" & #key .~ Just "B") + ] + failA1 row + | row ^. #outboxId == a1Id = pure (PublishFailed "wait") + | otherwise = pure PublishSucceeded + opts = + defaultPublishOptions + & #batchSize + .~ 1 + & #backoff + .~ ConstantBackoff 3600 + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + traverse_ (uncurry enqueueIntegrationEventTx) rows + Right failedPass <- Store.runStoreIO storeHandle (publishClaimedOutbox (perRow failA1) opts Nothing) + failedPass ^. #retried `shouldBe` 1 + now <- getCurrentTime + Right claimed <- Store.runStoreIO storeHandle (claimOutboxBatch PerKeyHeadOfLine 10 now) + fmap (^. #outboxId) claimed `shouldBe` [b1Id, b2Id] + Right (Just a2Row) <- Store.runStoreIO storeHandle (lookupOutbox a2Id) + a2Row ^. #status `shouldBe` OutboxPending + + it "claims contiguous per-source runs in one pass" $ \storeHandle -> do + let rows = + [ (outboxIdFromOrdinal 1, sampleIntegrationEnvelope & #messageId .~ "source-a1" & #key .~ Just "A") + , (outboxIdFromOrdinal 2, sampleIntegrationEnvelope & #messageId .~ "source-b1" & #key .~ Just "B") + , (outboxIdFromOrdinal 3, sampleIntegrationEnvelope & #messageId .~ "source-a2" & #key .~ Just "A") + , (outboxIdFromOrdinal 4, sampleIntegrationEnvelope & #messageId .~ "source-b2" & #key .~ Just "B") + ] + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + traverse_ (uncurry enqueueIntegrationEventTx) rows + now <- getCurrentTime + Right claimed <- Store.runStoreIO storeHandle (claimOutboxBatch PerSourceStream 10 now) + fmap (^. #outboxId) claimed `shouldBe` fmap fst rows + + it "claims null-keyed rows freely alongside keyed runs" $ \storeHandle -> do + let rows = + [ (outboxIdFromOrdinal 1, sampleIntegrationEnvelope & #messageId .~ "null-1" & #key .~ Nothing) + , (outboxIdFromOrdinal 2, sampleIntegrationEnvelope & #messageId .~ "keyed-1" & #key .~ Just "A") + , (outboxIdFromOrdinal 3, sampleIntegrationEnvelope & #messageId .~ "null-2" & #key .~ Nothing) + , (outboxIdFromOrdinal 4, sampleIntegrationEnvelope & #messageId .~ "keyed-2" & #key .~ Just "A") + ] + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + traverse_ (uncurry enqueueIntegrationEventTx) rows + now <- getCurrentTime + Right claimed <- Store.runStoreIO storeHandle (claimOutboxBatch PerKeyHeadOfLine 10 now) + fmap (^. #outboxId) claimed `shouldBe` fmap fst rows + + it "does not claim a tail while the previous run is still publishing" $ \storeHandle -> do + let rows = + [ (outboxIdFromOrdinal 1, sampleIntegrationEnvelope & #messageId .~ "publishing-a1" & #key .~ Just "A") + , (outboxIdFromOrdinal 2, sampleIntegrationEnvelope & #messageId .~ "publishing-a2" & #key .~ Just "A") + , (outboxIdFromOrdinal 3, sampleIntegrationEnvelope & #messageId .~ "publishing-a3" & #key .~ Just "A") + ] + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + traverse_ (uncurry enqueueIntegrationEventTx) rows + now <- getCurrentTime + Right firstClaim <- Store.runStoreIO storeHandle (claimOutboxBatch PerKeyHeadOfLine 10 now) + fmap (^. #outboxId) firstClaim `shouldBe` fmap fst rows + Right secondClaim <- Store.runStoreIO storeHandle (claimOutboxBatch PerKeyHeadOfLine 10 now) + secondClaim `shouldBe` [] + + it "marks a claimed row as sent with published_at set" $ \storeHandle -> do + let oid = OutboxId outboxUuid1 + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction (enqueueIntegrationEventTx oid sampleIntegrationEnvelope) + now <- getCurrentTime + Right [_] <- Store.runStoreIO storeHandle (claimOutboxBatch PerKeyHeadOfLine 10 now) + Right True <- Store.runStoreIO storeHandle (markOutboxSent oid now) + Right (Just row) <- Store.runStoreIO storeHandle (lookupOutbox oid) + row ^. #status `shouldBe` OutboxSent + row ^. #publishedAt `shouldSatisfy` isJust + row ^. #lastError `shouldBe` Nothing + + it "reclaims a row stranded in publishing by a crashed worker through maintenance" $ \storeHandle -> do + let oid = OutboxId outboxUuid1 + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction (enqueueIntegrationEventTx oid sampleIntegrationEnvelope) + now <- getCurrentTime + let pastNow = addUTCTime (-3600) now + Right [_] <- Store.runStoreIO storeHandle (claimOutboxBatch PerKeyHeadOfLine 10 now) + Right () <- Store.runStoreIO storeHandle (backdateOutboxUpdatedAt oid pastNow) + Right (Just stranded) <- Store.runStoreIO storeHandle (lookupOutbox oid) + stranded ^. #status `shouldBe` OutboxPublishing + publishedRef <- newIORef (0 :: Int) + let publish _ = do + liftIO (modifyIORef' publishedRef (+ 1)) + pure PublishSucceeded + Right noPublish <- Store.runStoreIO storeHandle (publishClaimedOutbox (perRow publish) defaultPublishOptions Nothing) + noPublish ^. #claimed `shouldBe` 0 + Right (Just stillStranded) <- Store.runStoreIO storeHandle (lookupOutbox oid) + stillStranded ^. #status `shouldBe` OutboxPublishing + Right maintenance <- Store.runStoreIO storeHandle (outboxMaintenancePass defaultMaintenanceOptions Nothing) + maintenance ^. #requeued `shouldBe` 1 + maintenance ^. #deadLettered `shouldBe` 0 + Right summary <- Store.runStoreIO storeHandle (publishClaimedOutbox (perRow publish) defaultPublishOptions Nothing) + summary ^. #published `shouldBe` 1 + published <- readIORef publishedRef + published `shouldBe` 1 + Right (Just row) <- Store.runStoreIO storeHandle (lookupOutbox oid) + row ^. #status `shouldBe` OutboxSent + + it "head-of-line traffic unwedges after reclaim" $ \storeHandle -> do + let firstId = OutboxId outboxUuid1 + secondId = OutboxId outboxUuid2 + first = sampleIntegrationEnvelope & #messageId .~ "stuck-first" & #key .~ Just "same-key" + second = sampleIntegrationEnvelope & #messageId .~ "stuck-second" & #key .~ Just "same-key" + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction (enqueueIntegrationEventTx firstId first) + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction (enqueueIntegrationEventTx secondId second) + now <- getCurrentTime + let pastNow = addUTCTime (-3600) now + Right [claimedFirst] <- Store.runStoreIO storeHandle (claimOutboxBatch PerKeyHeadOfLine 1 now) + claimedFirst ^. #outboxId `shouldBe` firstId + Right () <- Store.runStoreIO storeHandle (backdateOutboxUpdatedAt firstId pastNow) + publishedRef <- newIORef [] + let publish row = do + liftIO (modifyIORef' publishedRef (<> [row ^. #outboxId])) + pure PublishSucceeded + Right maintenance <- Store.runStoreIO storeHandle (outboxMaintenancePass defaultMaintenanceOptions Nothing) + maintenance ^. #requeued `shouldBe` 1 + Right firstPass <- Store.runStoreIO storeHandle (publishClaimedOutbox (perRow publish) defaultPublishOptions Nothing) + firstPass ^. #published `shouldBe` 2 + Right secondPass <- Store.runStoreIO storeHandle (publishClaimedOutbox (perRow publish) defaultPublishOptions Nothing) + secondPass ^. #published `shouldBe` 0 + published <- readIORef publishedRef + published `shouldBe` [firstId, secondId] + Right (Just secondRow) <- Store.runStoreIO storeHandle (lookupOutbox secondId) + secondRow ^. #status `shouldBe` OutboxSent + + it "does not reclaim a recently claimed row" $ \storeHandle -> do + let oid = OutboxId outboxUuid1 + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction (enqueueIntegrationEventTx oid sampleIntegrationEnvelope) + now <- getCurrentTime + Right [_] <- Store.runStoreIO storeHandle (claimOutboxBatch PerKeyHeadOfLine 10 now) + publishedRef <- newIORef (0 :: Int) + let publish _ = do + liftIO (modifyIORef' publishedRef (+ 1)) + pure PublishSucceeded + Right summary <- Store.runStoreIO storeHandle (publishClaimedOutbox (perRow publish) defaultPublishOptions Nothing) + summary ^. #claimed `shouldBe` 0 + published <- readIORef publishedRef + published `shouldBe` 0 + Right (Just row) <- Store.runStoreIO storeHandle (lookupOutbox oid) + row ^. #status `shouldBe` OutboxPublishing + + it "a throwing batch publish callback fails every row in that publish call" $ \storeHandle -> do + let throwId = OutboxId outboxUuid1 + okId = OutboxId outboxUuid2 + throwEvent = sampleIntegrationEnvelope & #messageId .~ "throwing-publish" & #key .~ Just "throw-key" + okEvent = sampleIntegrationEnvelope & #messageId .~ "ok-after-throw" & #key .~ Just "ok-key" + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction (enqueueIntegrationEventTx throwId throwEvent) + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction (enqueueIntegrationEventTx okId okEvent) + let publish row + | row ^. #outboxId == throwId = liftIO (throwIO (userError "kafka exploded")) + | otherwise = pure PublishSucceeded + Right summary <- + Store.runStoreIO storeHandle $ + publishClaimedOutbox (perRow publish) (defaultPublishOptions & #backoff .~ ConstantBackoff 0) Nothing + summary ^. #retried `shouldBe` 2 + summary ^. #published `shouldBe` 0 + Right (Just throwRow) <- Store.runStoreIO storeHandle (lookupOutbox throwId) + throwRow ^. #status `shouldBe` OutboxFailed + throwRow ^. #lastError `shouldSatisfy` maybe False (Text.isInfixOf "kafka exploded") + Right (Just okRow) <- Store.runStoreIO storeHandle (lookupOutbox okId) + okRow ^. #status `shouldBe` OutboxFailed + okRow ^. #lastError `shouldSatisfy` maybe False (Text.isInfixOf "kafka exploded") + + it "a row that exhausts attempts while crash-looping is dead-lettered by maintenance" $ \storeHandle -> do + let oid = OutboxId outboxUuid1 + opts = defaultMaintenanceOptions & #maxAttempts .~ 1 + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction (enqueueIntegrationEventTx oid sampleIntegrationEnvelope) + now <- getCurrentTime + let pastNow = addUTCTime (-3600) now + Right [_] <- Store.runStoreIO storeHandle (claimOutboxBatch PerKeyHeadOfLine 10 now) + Right () <- Store.runStoreIO storeHandle (backdateOutboxUpdatedAt oid pastNow) + Right summary <- Store.runStoreIO storeHandle (outboxMaintenancePass opts Nothing) + summary ^. #requeued `shouldBe` 0 + summary ^. #deadLettered `shouldBe` 1 + Right (Just row) <- Store.runStoreIO storeHandle (lookupOutbox oid) + row ^. #status `shouldBe` OutboxDead + + it "markOutboxSent does not resurrect a dead row" $ \storeHandle -> do + let oid = OutboxId outboxUuid1 + opts = defaultPublishOptions & #maxAttempts .~ 1 & #backoff .~ ConstantBackoff 0 + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction (enqueueIntegrationEventTx oid sampleIntegrationEnvelope) + let publish _ = pure (PublishFailed "boom") + Right _ <- Store.runStoreIO storeHandle (publishClaimedOutbox (perRow publish) opts Nothing) + now <- getCurrentTime + Right marked <- Store.runStoreIO storeHandle (markOutboxSent oid now) + marked `shouldBe` False + Right (Just row) <- Store.runStoreIO storeHandle (lookupOutbox oid) + row ^. #status `shouldBe` OutboxDead + + it "publishClaimedOutbox marks success and records failures with last_error" $ \storeHandle -> do + let okId = OutboxId outboxUuid1 + failId = OutboxId outboxUuid2 + okEvent = sampleIntegrationEnvelope + failEvent = + sampleIntegrationEnvelope + & #messageId + .~ "msg-fail-1" + & #key + .~ Just "order-789" + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction (enqueueIntegrationEventTx okId okEvent) + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction (enqueueIntegrationEventTx failId failEvent) + let publish row + | row ^. #outboxId == okId = pure PublishSucceeded + | otherwise = pure (PublishFailed "broker unreachable") + Right summary <- + Store.runStoreIO storeHandle (publishClaimedOutbox (perRow publish) defaultPublishOptions Nothing) + summary ^. #claimed `shouldBe` 2 + summary ^. #published `shouldBe` 1 + summary ^. #retried `shouldBe` 1 + summary ^. #dead `shouldBe` 0 + Right (Just okRow) <- Store.runStoreIO storeHandle (lookupOutbox okId) + okRow ^. #status `shouldBe` OutboxSent + Right (Just failRow) <- Store.runStoreIO storeHandle (lookupOutbox failId) + failRow ^. #status `shouldBe` OutboxFailed + failRow ^. #lastError `shouldBe` Just "broker unreachable" + + it "publishClaimedOutbox hands a same-key run to one batch publish call" $ \storeHandle -> do + let rows = + [ (outboxIdFromOrdinal (fromIntegral i), sampleIntegrationEnvelope & #messageId .~ ("batch-ok-" <> Text.pack (show i)) & #key .~ Just "batch-key") + | i <- [1 .. 10 :: Int] + ] + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + traverse_ (uncurry enqueueIntegrationEventTx) rows + invocationRef <- newIORef (0 :: Int) + let publish claimed = do + liftIO (modifyIORef' invocationRef (+ 1)) + pure [(row ^. #outboxId, PublishSucceeded) | row <- claimed] + Right summary <- Store.runStoreIO storeHandle (publishClaimedOutbox publish defaultPublishOptions Nothing) + summary ^. #claimed `shouldBe` 10 + summary ^. #published `shouldBe` 10 + invocations <- readIORef invocationRef + invocations `shouldBe` 1 + for_ (fmap fst rows) $ \oid -> do + Right (Just row) <- Store.runStoreIO storeHandle (lookupOutbox oid) + row ^. #status `shouldBe` OutboxSent + + it "publishClaimedOutbox skips the same-key suffix after a mid-run failure" $ \storeHandle -> do + let row1Id = outboxIdFromOrdinal 1 + row2Id = outboxIdFromOrdinal 2 + row3Id = outboxIdFromOrdinal 3 + row4Id = outboxIdFromOrdinal 4 + row5Id = outboxIdFromOrdinal 5 + ids = [row1Id, row2Id, row3Id, row4Id, row5Id] + rows = + [ (oid, sampleIntegrationEnvelope & #messageId .~ ("batch-fail-" <> Text.pack (show i)) & #key .~ Just "batch-fail-key") + | (i, oid) <- zip [1 .. 5 :: Int] ids + ] + publish claimed = + pure + [ ( row ^. #outboxId + , if row ^. #outboxId == row3Id + then PublishFailed "pivot failed" + else PublishSucceeded + ) + | row <- claimed + ] + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + traverse_ (uncurry enqueueIntegrationEventTx) rows + Right summary <- + Store.runStoreIO storeHandle $ + publishClaimedOutbox publish (defaultPublishOptions & #backoff .~ ConstantBackoff 0) Nothing + summary ^. #published `shouldBe` 2 + summary ^. #retried `shouldBe` 3 + Right (Just row1) <- Store.runStoreIO storeHandle (lookupOutbox row1Id) + Right (Just row2) <- Store.runStoreIO storeHandle (lookupOutbox row2Id) + Right (Just row3) <- Store.runStoreIO storeHandle (lookupOutbox row3Id) + Right (Just row4) <- Store.runStoreIO storeHandle (lookupOutbox row4Id) + Right (Just row5) <- Store.runStoreIO storeHandle (lookupOutbox row5Id) + row1 ^. #status `shouldBe` OutboxSent + row2 ^. #status `shouldBe` OutboxSent + row3 ^. #status `shouldBe` OutboxFailed + row3 ^. #attemptCount `shouldBe` 1 + row3 ^. #lastError `shouldBe` Just "pivot failed" + row4 ^. #status `shouldBe` OutboxFailed + row4 ^. #attemptCount `shouldBe` 0 + row4 ^. #lastError `shouldBe` Just "skipped: earlier record for the same key failed" + row5 ^. #status `shouldBe` OutboxFailed + row5 ^. #attemptCount `shouldBe` 0 + + it "PerSourceStream keeps one source's failure from skipping another source's rows" $ \storeHandle -> do + let rowA1 = outboxIdFromOrdinal 1 + rowB1 = outboxIdFromOrdinal 2 + rowA2 = outboxIdFromOrdinal 3 + rowB2 = outboxIdFromOrdinal 4 + mkRow oid src msgId = + (oid, sampleIntegrationEnvelope & #messageId .~ msgId & #source .~ src & #key .~ Nothing) + rows = + [ mkRow rowA1 "per-source-a" "ps-a1" + , mkRow rowB1 "per-source-b" "ps-b1" + , mkRow rowA2 "per-source-a" "ps-a2" + , mkRow rowB2 "per-source-b" "ps-b2" + ] + publish claimed = + pure + [ ( row ^. #outboxId + , if row ^. #outboxId == rowA2 + then PublishFailed "source-a pivot failed" + else PublishSucceeded + ) + | row <- claimed + ] + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + traverse_ (uncurry enqueueIntegrationEventTx) rows + Right summary <- + Store.runStoreIO storeHandle $ + publishClaimedOutbox publish (defaultPublishOptions & #orderingPolicy .~ PerSourceStream & #backoff .~ ConstantBackoff 0) Nothing + summary ^. #claimed `shouldBe` 4 + summary ^. #published `shouldBe` 3 + summary ^. #retried `shouldBe` 1 + Right (Just a1) <- Store.runStoreIO storeHandle (lookupOutbox rowA1) + Right (Just a2) <- Store.runStoreIO storeHandle (lookupOutbox rowA2) + Right (Just b1) <- Store.runStoreIO storeHandle (lookupOutbox rowB1) + Right (Just b2) <- Store.runStoreIO storeHandle (lookupOutbox rowB2) + a1 ^. #status `shouldBe` OutboxSent + a2 ^. #status `shouldBe` OutboxFailed + a2 ^. #attemptCount `shouldBe` 1 + a2 ^. #lastError `shouldBe` Just "source-a pivot failed" + b1 ^. #status `shouldBe` OutboxSent + b2 ^. #status `shouldBe` OutboxSent + + it "a late failure mark does not clobber a row that already reached a terminal state" $ \storeHandle -> do + let oid = OutboxId outboxUuid1 + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction (enqueueIntegrationEventTx oid sampleIntegrationEnvelope) + now <- getCurrentTime + Right [_] <- Store.runStoreIO storeHandle (claimOutboxBatch PerKeyHeadOfLine 10 now) + Right True <- Store.runStoreIO storeHandle (markOutboxSent oid now) + Right _ <- + Store.runStoreIO storeHandle $ + Store.runTransaction (markOutboxFailedTx oid "late failure from a timed-out worker" 5 60 now) + Right (Just row) <- Store.runStoreIO storeHandle (lookupOutbox oid) + row ^. #status `shouldBe` OutboxSent + row ^. #lastError `shouldBe` Nothing + + it "claims nothing while another transaction holds an uncommitted claim on a key's head" $ \storeHandle -> do + let headId = outboxIdFromOrdinal 1 + tailId = outboxIdFromOrdinal 2 + rows = + [ (headId, sampleIntegrationEnvelope & #messageId .~ "claim-race-1" & #key .~ Just "claim-race-key") + , (tailId, sampleIntegrationEnvelope & #messageId .~ "claim-race-2" & #key .~ Just "claim-race-key") + ] + OutboxId headUuid = headId + holdClaimSql = + TE.encodeUtf8 $ + "UPDATE keiro.keiro_outbox SET status = 'publishing', attempt_count = attempt_count + 1, updated_at = now() WHERE outbox_id = '" + <> UUID.toText headUuid + <> "'" + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + traverse_ (uncurry enqueueIntegrationEventTx) rows + holderDone <- newEmptyMVar + _ <- forkIO $ do + holder <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ do + Tx.sql holdClaimSql + Tx.sql "SELECT pg_sleep(2)" + putMVar holderDone holder + -- Let the holder acquire its uncommitted row lock, then race a claim. + threadDelay 500000 + now <- getCurrentTime + Right claimed <- Store.runStoreIO storeHandle (claimOutboxBatch PerKeyHeadOfLine 10 now) + fmap (^. #outboxId) claimed `shouldBe` [] + Right () <- takeMVar holderDone + pure () + + it "StopTheLine publishes singleton batches and skips the unattempted suffix" $ \storeHandle -> do + let row1Id = outboxIdFromOrdinal 1 + row2Id = outboxIdFromOrdinal 2 + row3Id = outboxIdFromOrdinal 3 + row4Id = outboxIdFromOrdinal 4 + ids = [row1Id, row2Id, row3Id, row4Id] + rows = + [ (oid, sampleIntegrationEnvelope & #messageId .~ ("stop-line-" <> Text.pack (show i)) & #key .~ Just "stop-key") + | (i, oid) <- zip [1 .. 4 :: Int] ids + ] + publishRef = fmap (^. #outboxId) + publish claimed = + pure + [ ( row ^. #outboxId + , if row ^. #outboxId == row2Id + then PublishFailed "stop here" + else PublishSucceeded + ) + | row <- claimed + ] + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + traverse_ (uncurry enqueueIntegrationEventTx) rows + seenRef <- newIORef [] + let trackedPublish claimed = do + liftIO (modifyIORef' seenRef (<> publishRef claimed)) + publish claimed + opts = defaultPublishOptions & #orderingPolicy .~ StopTheLine & #backoff .~ ConstantBackoff 0 + Right summary <- Store.runStoreIO storeHandle (publishClaimedOutbox trackedPublish opts Nothing) + summary ^. #published `shouldBe` 1 + summary ^. #retried `shouldBe` 3 + summary ^. #haltedOn `shouldBe` Just row2Id + seen <- readIORef seenRef + seen `shouldBe` take 2 ids + Right (Just row3) <- Store.runStoreIO storeHandle (lookupOutbox row3Id) + Right (Just row4) <- Store.runStoreIO storeHandle (lookupOutbox row4Id) + row3 ^. #status `shouldBe` OutboxFailed + row3 ^. #attemptCount `shouldBe` 0 + row4 ^. #status `shouldBe` OutboxFailed + row4 ^. #attemptCount `shouldBe` 0 + + it "publishClaimedOutbox treats a missing batch outcome as a failed row" $ \storeHandle -> do + let okId = outboxIdFromOrdinal 1 + missingId = outboxIdFromOrdinal 2 + okEvent = sampleIntegrationEnvelope & #messageId .~ "missing-outcome-ok" & #key .~ Just "ok-key" + missingEvent = sampleIntegrationEnvelope & #messageId .~ "missing-outcome-fail" & #key .~ Just "missing-key" + publish claimed = + pure + [ (row ^. #outboxId, PublishSucceeded) + | row <- claimed + , row ^. #outboxId == okId + ] + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ do + enqueueIntegrationEventTx okId okEvent + enqueueIntegrationEventTx missingId missingEvent + Right summary <- Store.runStoreIO storeHandle (publishClaimedOutbox publish defaultPublishOptions Nothing) + summary ^. #published `shouldBe` 1 + summary ^. #retried `shouldBe` 1 + Right (Just missingRow) <- Store.runStoreIO storeHandle (lookupOutbox missingId) + missingRow ^. #status `shouldBe` OutboxFailed + missingRow ^. #lastError `shouldBe` Just "publisher returned no outcome" + + it "auto-dead-letters a row after maxAttempts consecutive failures" $ \storeHandle -> do + let oid = OutboxId outboxUuid1 + event = sampleIntegrationEnvelope & #key .~ Nothing + opts = + defaultPublishOptions + & #batchSize + .~ 10 + & #maxAttempts + .~ 3 + & #backoff + .~ ConstantBackoff 0 + & #orderingPolicy + .~ BestEffort + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction (enqueueIntegrationEventTx oid event) + let publish _ = pure (PublishFailed "broker exploded") + -- First two failures retain Failed status. + Right s1 <- Store.runStoreIO storeHandle (publishClaimedOutbox (perRow publish) opts Nothing) + s1 ^. #retried `shouldBe` 1 + s1 ^. #dead `shouldBe` 0 + Right s2 <- Store.runStoreIO storeHandle (publishClaimedOutbox (perRow publish) opts Nothing) + s2 ^. #retried `shouldBe` 1 + s2 ^. #dead `shouldBe` 0 + -- Third failure crosses the threshold. + Right s3 <- Store.runStoreIO storeHandle (publishClaimedOutbox (perRow publish) opts Nothing) + s3 ^. #dead `shouldBe` 1 + Right (Just row) <- Store.runStoreIO storeHandle (lookupOutbox oid) + row ^. #status `shouldBe` OutboxDead + -- A dead row is not claimable. + now <- getCurrentTime + Right reclaimed <- Store.runStoreIO storeHandle (claimOutboxBatch BestEffort 10 now) + reclaimed `shouldBe` [] + + it "garbageCollectSent deletes only old sent rows" $ \storeHandle -> do + let oldSentId = OutboxId outboxUuid1 + recentSentId = OutboxId outboxUuid2 + failedId = OutboxId outboxUuid3 + deadId = OutboxId outboxUuid4 + base = sampleIntegrationEnvelope & #key .~ Nothing + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction (enqueueIntegrationEventTx oldSentId (base & #messageId .~ "gc-old-sent")) + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction (enqueueIntegrationEventTx recentSentId (base & #messageId .~ "gc-recent-sent")) + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction (enqueueIntegrationEventTx failedId (base & #messageId .~ "gc-failed")) + let firstPass row + | row ^. #outboxId == failedId = pure (PublishFailed "keep failed") + | otherwise = pure PublishSucceeded + firstPassOpts = + defaultPublishOptions + & #batchSize + .~ 10 + & #orderingPolicy + .~ BestEffort + & #backoff + .~ ConstantBackoff 3600 + Right _ <- Store.runStoreIO storeHandle (publishClaimedOutbox (perRow firstPass) firstPassOpts Nothing) + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction (enqueueIntegrationEventTx deadId (base & #messageId .~ "gc-dead")) + let deadPass row + | row ^. #outboxId == deadId = pure (PublishFailed "keep dead") + | otherwise = pure PublishSucceeded + deadPassOpts = + defaultPublishOptions + & #batchSize + .~ 10 + & #maxAttempts + .~ 1 + & #orderingPolicy + .~ BestEffort + Right _ <- Store.runStoreIO storeHandle (publishClaimedOutbox (perRow deadPass) deadPassOpts Nothing) + now <- getCurrentTime + Right () <- Store.runStoreIO storeHandle (backdateOutboxPublishedAt oldSentId (addUTCTime (-3600) now)) + Right deleted <- Store.runStoreIO storeHandle (garbageCollectSent 300 now) + deleted `shouldBe` 1 + Right oldRow <- Store.runStoreIO storeHandle (lookupOutbox oldSentId) + oldRow `shouldBe` Nothing + Right (Just recentRow) <- Store.runStoreIO storeHandle (lookupOutbox recentSentId) + recentRow ^. #status `shouldBe` OutboxSent + Right (Just failedRow) <- Store.runStoreIO storeHandle (lookupOutbox failedId) + failedRow ^. #status `shouldBe` OutboxFailed + Right (Just deadRow) <- Store.runStoreIO storeHandle (lookupOutbox deadId) + deadRow ^. #status `shouldBe` OutboxDead + + it "enforces per-key head-of-line blocking and unblocks once the predecessor reaches a terminal state" $ \storeHandle -> do + let a1Id = OutboxId outboxUuid1 + a2Id = OutboxId outboxUuid2 + b1Id = OutboxId outboxUuid3 + a1 = sampleIntegrationEnvelope & #messageId .~ "a1" & #key .~ Just "k1" + a2 = sampleIntegrationEnvelope & #messageId .~ "a2" & #key .~ Just "k1" + b1 = sampleIntegrationEnvelope & #messageId .~ "b1" & #key .~ Just "k2" + -- Insert in created_at order (a1 first, then a2, then b1). + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction (enqueueIntegrationEventTx a1Id a1) + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction (enqueueIntegrationEventTx a2Id a2) + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction (enqueueIntegrationEventTx b1Id b1) + claimed <- newIORef [] + let publish row = do + liftIO (atomicModifyIORef' claimed (\xs -> ((row ^. #outboxId) : xs, ()))) + if row ^. #outboxId == a1Id + then pure (PublishFailed "broker hiccup") + else pure PublishSucceeded + -- First pass: with a one-row batch, a1 fails and both later rows remain pending. + let firstPassOpts = + defaultPublishOptions + & #batchSize + .~ 1 + & #backoff + .~ ConstantBackoff 0 + Right summary1 <- + Store.runStoreIO storeHandle (publishClaimedOutbox (perRow publish) firstPassOpts Nothing) + summary1 ^. #claimed `shouldBe` 1 + claimedIds <- readIORef claimed + claimedIds `shouldSatisfy` (a2Id `notElem`) + claimedIds `shouldSatisfy` (a1Id `elem`) + claimedIds `shouldSatisfy` (b1Id `notElem`) + Right (Just a1Row) <- Store.runStoreIO storeHandle (lookupOutbox a1Id) + a1Row ^. #status `shouldBe` OutboxFailed + Right (Just b1Row) <- Store.runStoreIO storeHandle (lookupOutbox b1Id) + b1Row ^. #status `shouldBe` OutboxPending + Right (Just a2Row) <- Store.runStoreIO storeHandle (lookupOutbox a2Id) + a2Row ^. #status `shouldBe` OutboxPending + -- Drive a1 to terminal sent state so a2 can move. One pass claims a1 + -- (now that next_attempt_at has passed). A second pass claims a2, + -- which becomes head-of-line once a1 reaches `sent`. + writeIORef claimed [] + let publishOk row = do + liftIO (atomicModifyIORef' claimed (\xs -> ((row ^. #outboxId) : xs, ()))) + pure PublishSucceeded + retryOpts = + defaultPublishOptions + & #batchSize + .~ 1 + & #backoff + .~ ConstantBackoff 0 + Right _ <- Store.runStoreIO storeHandle (publishClaimedOutbox (perRow publishOk) retryOpts Nothing) + Right _ <- Store.runStoreIO storeHandle (publishClaimedOutbox (perRow publishOk) retryOpts Nothing) + Right _ <- Store.runStoreIO storeHandle (publishClaimedOutbox (perRow publishOk) retryOpts Nothing) + claimedIds2 <- readIORef claimed + claimedIds2 `shouldSatisfy` (a1Id `elem`) + claimedIds2 `shouldSatisfy` (a2Id `elem`) + claimedIds2 `shouldSatisfy` (b1Id `elem`) + Right (Just a2Row') <- Store.runStoreIO storeHandle (lookupOutbox a2Id) + a2Row' ^. #status `shouldBe` OutboxSent + + it "allows null-keyed rows to publish independently" $ \storeHandle -> do + let n1 = OutboxId outboxUuid1 + n2 = OutboxId outboxUuid2 + e = sampleIntegrationEnvelope & #key .~ Nothing + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction (enqueueIntegrationEventTx n1 (e & #messageId .~ "n1")) + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction (enqueueIntegrationEventTx n2 (e & #messageId .~ "n2")) + let publish row + | row ^. #outboxId == n1 = pure (PublishFailed "transient") + | otherwise = pure PublishSucceeded + Right summary <- + Store.runStoreIO storeHandle $ + publishClaimedOutbox (perRow publish) (defaultPublishOptions & #backoff .~ ConstantBackoff 0) Nothing + summary ^. #claimed `shouldBe` 2 + summary ^. #published `shouldBe` 1 + summary ^. #retried `shouldBe` 1 + + it "mints message ids with the configured TypeID prefix" $ \storeHandle -> do + Right minted <- + Store.runStoreIO storeHandle (mintIntegrationEvent sampleProducer sampleDraft) + minted ^. #source `shouldBe` "ordering" + minted ^. #destination `shouldBe` "billing.orders.v1" + Text.isPrefixOf "msg_" (minted ^. #messageId) `shouldBe` True + + it "validates integration producer message id prefixes before startup" $ \_storeHandle -> do + shouldBeRight_ (mkIntegrationProducer sampleProducer) + case mkIntegrationProducer (sampleProducer & #messageIdPrefix .~ "Bad-Prefix") of + Left (InvalidMessageIdPrefix prefix reason) -> do + prefix `shouldBe` "Bad-Prefix" + reason `shouldSatisfy` (not . Text.null) + other -> expectationFailure ("expected invalid prefix, got " <> show (void other)) + + it "draftToEvent stamps source and messageId without minting" $ \_storeHandle -> do + let event = draftToEvent "ordering" "msg-fixed-1" sampleDraft + event ^. #messageId `shouldBe` "msg-fixed-1" + event ^. #source `shouldBe` "ordering" + event ^. #destination `shouldBe` "billing.orders.v1" + + it "freshOutboxId returns distinct UUIDv7 ids" $ \storeHandle -> do + Right ids <- + Store.runStoreIO storeHandle (traverse (\_ -> freshOutboxId) [1 .. 4 :: Int]) + length ids `shouldBe` 4 + length (uniqueIds ids) `shouldBe` 4 + + it "publishClaimedOutbox emits a Producer span with messaging semconv attributes" $ \storeHandle -> do + (processor, spansRef) <- inMemoryListExporter + provider <- createTracerProvider [processor] emptyTracerProviderOptions + let tracer = makeTracer provider "keiro-test" tracerOptions + okId = OutboxId outboxUuid1 + failId = OutboxId outboxUuid2 + okEvent = sampleIntegrationEnvelope + failEvent = + sampleIntegrationEnvelope + & #messageId + .~ "msg-fail-otel-1" + & #key + .~ Just "order-otel-fail" + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction (enqueueIntegrationEventTx okId okEvent) + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction (enqueueIntegrationEventTx failId failEvent) + let publish row + | row ^. #outboxId == okId = pure PublishSucceeded + | otherwise = pure (PublishFailed "broker unreachable") + opts = defaultPublishOptions & #tracer ?~ tracer + Right _ <- Store.runStoreIO storeHandle (publishClaimedOutbox (perRow publish) opts Nothing) + _ <- shutdownTracerProvider provider Nothing + spans <- traverse captureSpan =<< readIORef spansRef + length spans `shouldBe` 1 + case spans of + [batchSpan] -> do + csName batchSpan `shouldBe` ("send " <> (okEvent ^. #destination)) + show (csKind batchSpan) `shouldBe` "Producer" + textAttr (csAttributes batchSpan) "messaging.system" `shouldBe` Just "kafka" + textAttr (csAttributes batchSpan) "messaging.operation.type" `shouldBe` Just "publish" + textAttr (csAttributes batchSpan) "messaging.operation.name" `shouldBe` Just "send" + textAttr (csAttributes batchSpan) "messaging.destination.name" + `shouldBe` Just (okEvent ^. #destination) + textAttr (csAttributes batchSpan) "messaging.kafka.message.key" + `shouldBe` (okEvent ^. #key) + intAttr (csAttributes batchSpan) "keiro.outbox.batch.size" `shouldBe` Just 2 + textAttr (csAttributes batchSpan) "error.type" `shouldBe` Just "publish_failed" + case csStatus batchSpan of + Error msg -> msg `shouldBe` "broker unreachable" + other -> expectationFailure ("expected Error \"broker unreachable\", got " <> show other) + other -> expectationFailure ("expected one batch span, got " <> show (length other)) + + it "publishClaimedOutbox records counters and sampleOutboxBacklog records the gauge" $ \storeHandle -> do + (exporter, metricsRef) <- inMemoryMetricExporter + (provider, _env) <- + createMeterProvider + emptyMaterializedResources + defaultSdkMeterProviderOptions{metricExporter = Just exporter} + meter <- getMeter provider Telemetry.keiroInstrumentationLibrary + keiroMetrics <- Telemetry.newKeiroMetrics meter + let okId = OutboxId outboxUuid1 + failId = OutboxId outboxUuid2 + okEvent = sampleIntegrationEnvelope & #messageId .~ "metrics-ok" & #key .~ Nothing + failEvent = sampleIntegrationEnvelope & #messageId .~ "metrics-fail" & #key .~ Nothing + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction (enqueueIntegrationEventTx okId okEvent) + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction (enqueueIntegrationEventTx failId failEvent) + let publish row + | row ^. #outboxId == okId = pure PublishSucceeded + | otherwise = pure (PublishFailed "broker down") + retryPassOpts = + defaultPublishOptions + & #batchSize + .~ 10 + & #maxAttempts + .~ 5 + & #backoff + .~ ConstantBackoff 0 + & #orderingPolicy + .~ BestEffort + deadPassOpts = retryPassOpts & #maxAttempts .~ 1 + -- Pass 1 (maxAttempts = 5): ok publishes, the fail row retries. + Right summary1 <- + Store.runStoreIO storeHandle (publishClaimedOutbox (perRow publish) retryPassOpts (Just keiroMetrics)) + summary1 ^. #published `shouldBe` 1 + summary1 ^. #retried `shouldBe` 1 + -- Pass 2 (maxAttempts = 1): the failed row crosses the ceiling and dies. + Right summary2 <- + Store.runStoreIO storeHandle (publishClaimedOutbox (perRow publish) deadPassOpts (Just keiroMetrics)) + summary2 ^. #dead `shouldBe` 1 + -- Flush so the in-memory exporter receives the aggregates. + _ <- forceFlushMeterProvider provider Nothing + exported <- readIORef metricsRef + let scalars = flattenScalarPoints exported + -- Counters are cumulative across both passes. + lookup "keiro.outbox.published" scalars `shouldBe` Just (IntNumber 1) + lookup "keiro.outbox.retried" scalars `shouldBe` Just (IntNumber 1) + lookup "keiro.outbox.deadlettered" scalars `shouldBe` Just (IntNumber 1) + -- Publish passes no longer run the backlog COUNT(*) on the hot path. + lookup "keiro.outbox.backlog" scalars `shouldBe` Nothing + + Store.runStoreIO storeHandle (sampleOutboxBacklog (Just keiroMetrics)) `shouldReturn` Right () + _ <- forceFlushMeterProvider provider Nothing + sampled <- readIORef metricsRef + let sampledScalars = flattenScalarPoints sampled + lookup "keiro.outbox.backlog" sampledScalars `shouldBe` Just (IntNumber 0) + + describe "Keiro.Inbox" $ around (withFreshStore fixture) $ do + it "runs the handler once and records the row as completed" $ \storeHandle -> do + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction (Tx.sql "CREATE TABLE IF NOT EXISTS inbox_test_counter (message_id TEXT PRIMARY KEY)") + let event = + sampleIntegrationEnvelope + & #messageId + .~ "inbox-msg-1" + & #source + .~ "ordering" + handler ev = + Tx.statement (ev ^. #messageId) inboxTestCounterInsertStmt + Right result1 <- + Store.runStoreIO storeHandle $ + runInboxTransaction Nothing PreferIntegrationMessageId event Nothing handler + case result1 of + Right (InboxProcessed ()) -> pure () + other -> expectationFailure ("expected InboxProcessed, got " <> show other) + Right rowCount1 <- + Store.runStoreIO storeHandle $ + Store.runTransaction (Tx.statement () inboxTestCounterCountStmt) + rowCount1 `shouldBe` 1 + Right (Just inboxRow) <- Store.runStoreIO storeHandle (lookupInbox "ordering" "inbox-msg-1") + inboxRow ^. #status `shouldBe` InboxCompleted + inboxRow ^. #completedAt `shouldSatisfy` isJust + + it "treats a redelivery with the same messageId as a duplicate" $ \storeHandle -> do + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction (Tx.sql "CREATE TABLE IF NOT EXISTS inbox_test_counter (message_id TEXT PRIMARY KEY)") + let event = + sampleIntegrationEnvelope + & #messageId + .~ "inbox-msg-dup" + & #source + .~ "ordering" + handler ev = Tx.statement (ev ^. #messageId) inboxTestCounterInsertStmt + Right (Right (InboxProcessed ())) <- + Store.runStoreIO storeHandle $ + runInboxTransaction Nothing PreferIntegrationMessageId event Nothing handler + Right result2 <- + Store.runStoreIO storeHandle $ + runInboxTransaction Nothing PreferIntegrationMessageId event Nothing handler + result2 `shouldBe` Right InboxDuplicate + Right rowCount <- + Store.runStoreIO storeHandle $ + Store.runTransaction (Tx.statement () inboxTestCounterCountStmt) + rowCount `shouldBe` 1 + + it "records inbox counters and samples backlog separately under the in-memory exporter" $ \storeHandle -> do + (exporter, metricsRef) <- inMemoryMetricExporter + (provider, _env) <- + createMeterProvider + emptyMaterializedResources + defaultSdkMeterProviderOptions{metricExporter = Just exporter} + meter <- getMeter provider Telemetry.keiroInstrumentationLibrary + keiroMetrics <- Telemetry.newKeiroMetrics meter + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction (Tx.sql "CREATE TABLE IF NOT EXISTS inbox_test_counter (message_id TEXT PRIMARY KEY)") + let event = sampleIntegrationEnvelope & #messageId .~ "inbox-metrics-dup" & #source .~ "ordering" + handler ev = Tx.statement (ev ^. #messageId) inboxTestCounterInsertStmt + -- First delivery runs the handler: processed. + Right (Right (InboxProcessed ())) <- + Store.runStoreIO storeHandle $ + runInboxTransaction (Just keiroMetrics) PreferIntegrationMessageId event Nothing handler + -- Second delivery of the same (source, message_id): duplicate. + Right result2 <- + Store.runStoreIO storeHandle $ + runInboxTransaction (Just keiroMetrics) PreferIntegrationMessageId event Nothing handler + result2 `shouldBe` Right InboxDuplicate + _ <- forceFlushMeterProvider provider Nothing + exported <- readIORef metricsRef + let scalars = flattenScalarPoints exported + lookup "keiro.inbox.processed" scalars `shouldBe` Just (IntNumber 1) + lookup "keiro.inbox.duplicates" scalars `shouldBe` Just (IntNumber 1) + lookup "keiro.inbox.backlog" scalars `shouldBe` Nothing + Store.runStoreIO storeHandle (sampleInboxBacklog (Just keiroMetrics)) `shouldReturn` Right () + _ <- forceFlushMeterProvider provider Nothing + sampled <- readIORef metricsRef + let sampledScalars = flattenScalarPoints sampled + lookup "keiro.inbox.backlog" sampledScalars `shouldBe` Just (IntNumber 0) + -- The handler ran exactly once (the duplicate path does not re-run it). + Right rowCount <- + Store.runStoreIO storeHandle $ + Store.runTransaction (Tx.statement () inboxTestCounterCountStmt) + rowCount `shouldBe` 1 + + it "deduplicates via PreferSourceEventIdentity even when messageId differs" $ \storeHandle -> do + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction (Tx.sql "CREATE TABLE IF NOT EXISTS inbox_test_counter (message_id TEXT PRIMARY KEY)") + let shared = sampleIntegrationEnvelope & #source .~ "ordering" + first = shared & #messageId .~ "republish-1" + second = shared & #messageId .~ "republish-2" + handler ev = Tx.statement (ev ^. #messageId) inboxTestCounterInsertStmt + Right (Right (InboxProcessed ())) <- + Store.runStoreIO storeHandle $ + runInboxTransaction Nothing PreferSourceEventIdentity first Nothing handler + Right result2 <- + Store.runStoreIO storeHandle $ + runInboxTransaction Nothing PreferSourceEventIdentity second Nothing handler + result2 `shouldBe` Right InboxDuplicate + + it "uses KafkaDeliveryIdentity when supplied" $ \storeHandle -> do + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction (Tx.sql "CREATE TABLE IF NOT EXISTS inbox_test_counter (message_id TEXT PRIMARY KEY)") + let event = sampleIntegrationEnvelope & #source .~ "ordering" + kafka = KafkaDeliveryRef "billing.orders.v1" 0 17 + handler ev = Tx.statement (ev ^. #messageId) inboxTestCounterInsertStmt + Right (Right (InboxProcessed ())) <- + Store.runStoreIO storeHandle $ + runInboxTransaction Nothing KafkaDeliveryIdentity event (Just kafka) handler + Right (Right InboxDuplicate) <- + Store.runStoreIO storeHandle $ + runInboxTransaction Nothing KafkaDeliveryIdentity event (Just kafka) handler + Right (Just row) <- + Store.runStoreIO storeHandle $ + lookupInbox "ordering" "billing.orders.v1:0:17" + row ^. #status `shouldBe` InboxCompleted + + it "reports DedupePolicyUnsatisfied when the envelope lacks the required field" $ \storeHandle -> do + let event = + sampleIntegrationEnvelope + & #source + .~ "ordering" + & #sourceEventId + .~ Nothing + & #sourceGlobalPosition + .~ Nothing + Right result <- + Store.runStoreIO storeHandle $ + runInboxTransaction Nothing PreferSourceEventIdentity event Nothing (\_ -> pure ()) + result `shouldBe` Left (DedupePolicyUnsatisfied PreferSourceEventIdentity) + + it "leaves no inbox row when the handler condemns the transaction" $ \storeHandle -> do + let event = + sampleIntegrationEnvelope + & #messageId + .~ "inbox-msg-rollback" + & #source + .~ "ordering" + handler _ = do + Tx.condemn + pure () + _ <- + Store.runStoreIO storeHandle $ + runInboxTransaction Nothing PreferIntegrationMessageId event Nothing handler + Right row <- Store.runStoreIO storeHandle (lookupInbox "ordering" "inbox-msg-rollback") + row `shouldBe` Nothing + + it "leaves no inbox row when the plain handler throws" $ \storeHandle -> do + let event = + sampleIntegrationEnvelope + & #messageId + .~ "inbox-msg-throw-plain" + & #source + .~ "ordering" + handler _ = (pure $! error "plain inbox handler failed") :: Tx.Transaction () + thrown <- + try $ + Store.runStoreIO storeHandle $ + runInboxTransaction Nothing PreferIntegrationMessageId event Nothing handler + case thrown of + Left (_ :: SomeException) -> pure () + Right other -> expectationFailure ("expected handler exception, got " <> show (void other)) + Right row <- Store.runStoreIO storeHandle (lookupInbox "ordering" "inbox-msg-throw-plain") + row `shouldBe` Nothing + + it "exports markFailedTx from the public inbox module and preserves explicit failure marks" $ \storeHandle -> do + let event = + sampleIntegrationEnvelope + & #messageId + .~ "inbox-msg-public-failed" + & #source + .~ "ordering" + handler _ = do + markFailedTx "ordering" "inbox-msg-public-failed" "operator failed" (event ^. #occurredAt) + pure () + Right (Right (InboxProcessed ())) <- + Store.runStoreIO storeHandle $ + runInboxTransaction Nothing PreferIntegrationMessageId event Nothing handler + Right (Just row) <- Store.runStoreIO storeHandle (lookupInbox "ordering" "inbox-msg-public-failed") + row ^. #status `shouldBe` InboxFailed + row ^. #lastError `shouldBe` Just "operator failed" + + it "a throwing handler records a failed attempt instead of looping" $ \storeHandle -> do + let event = + sampleIntegrationEnvelope + & #messageId + .~ "inbox-msg-poison-1" + & #source + .~ "ordering" + handler _ = (pure $! error "inbox exploded") :: Tx.Transaction () + Right result <- + Store.runStoreIO storeHandle $ + runInboxTransactionWithRetries Nothing 3 PreferIntegrationMessageId event Nothing handler + case result of + Right (InboxHandlerFailed err attempts) -> do + Text.isInfixOf "inbox exploded" err `shouldBe` True + attempts `shouldBe` 1 + other -> expectationFailure ("expected InboxHandlerFailed, got " <> show other) + Right (Just row) <- Store.runStoreIO storeHandle (lookupInbox "ordering" "inbox-msg-poison-1") + row ^. #status `shouldBe` InboxFailed + row ^. #attemptCount `shouldBe` 1 + row ^. #lastError `shouldSatisfy` maybe False (Text.isInfixOf "inbox exploded") + + it "a transient poison message succeeds on retry" $ \storeHandle -> do + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction (Tx.sql "CREATE TABLE IF NOT EXISTS inbox_test_counter (message_id TEXT PRIMARY KEY)") + let event = + sampleIntegrationEnvelope + & #messageId + .~ "inbox-msg-poison-transient" + & #source + .~ "ordering" + failOnce _ = (pure $! error "temporary inbox failure") :: Tx.Transaction () + succeeding ev = Tx.statement (ev ^. #messageId) inboxTestCounterInsertStmt + Right result1 <- + Store.runStoreIO storeHandle $ + runInboxTransactionWithRetries Nothing 3 PreferIntegrationMessageId event Nothing failOnce + case result1 of + Right (InboxHandlerFailed _ 1) -> pure () + other -> expectationFailure ("expected first failed attempt, got " <> show other) + Right result2 <- + Store.runStoreIO storeHandle $ + runInboxTransactionWithRetries Nothing 3 PreferIntegrationMessageId event Nothing succeeding + result2 `shouldBe` Right (InboxProcessed ()) + Right (Just row) <- Store.runStoreIO storeHandle (lookupInbox "ordering" "inbox-msg-poison-transient") + row ^. #status `shouldBe` InboxCompleted + row ^. #attemptCount `shouldBe` 1 + Right rowCount <- + Store.runStoreIO storeHandle $ + Store.runTransaction (Tx.statement () inboxTestCounterCountStmt) + rowCount `shouldBe` 1 + + it "an unrecoverable message dead-letters at the ceiling" $ \storeHandle -> do + let event = + sampleIntegrationEnvelope + & #messageId + .~ "inbox-msg-poison-dead" + & #source + .~ "ordering" + handler _ = (pure $! error "always broken") :: Tx.Transaction () + Right result1 <- + Store.runStoreIO storeHandle $ + runInboxTransactionWithRetries Nothing 2 PreferIntegrationMessageId event Nothing handler + Right result2 <- + Store.runStoreIO storeHandle $ + runInboxTransactionWithRetries Nothing 2 PreferIntegrationMessageId event Nothing handler + Right result3 <- + Store.runStoreIO storeHandle $ + runInboxTransactionWithRetries Nothing 2 PreferIntegrationMessageId event Nothing handler + case (result1, result2, result3) of + ( Right (InboxHandlerFailed _ 1) + , Right (InboxHandlerFailed _ 2) + , Right (InboxPreviouslyFailed _) + ) -> pure () + other -> expectationFailure ("unexpected poison lifecycle: " <> show other) + Right (Just row) <- Store.runStoreIO storeHandle (lookupInbox "ordering" "inbox-msg-poison-dead") + row ^. #status `shouldBe` InboxFailed + row ^. #attemptCount `shouldBe` 2 + + it "processes a batch of distinct messages in one transaction" $ \storeHandle -> do + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction (Tx.sql "CREATE TABLE IF NOT EXISTS inbox_test_counter (message_id TEXT PRIMARY KEY)") + let events = + [ sampleIntegrationEnvelope + & #messageId + .~ ("inbox-batch-msg-" <> Text.pack (show n)) + & #source + .~ "batch-ordering" + | n <- [1 .. 50 :: Int] + ] + handler ev = Tx.statement (ev ^. #messageId) inboxTestCounterInsertStmt + Right results <- + Store.runStoreIO storeHandle $ + runInboxTransactionBatch Nothing 3 PreferIntegrationMessageId PersistFullEnvelope ((,Nothing) <$> events) handler + results `shouldBe` replicate 50 (Right (InboxProcessed ())) + Right rowCount <- + Store.runStoreIO storeHandle $ + Store.runTransaction (Tx.statement () inboxTestCounterCountStmt) + rowCount `shouldBe` 50 + Right inboxRows <- Store.runStoreIO storeHandle (listInbox "batch-ordering") + length inboxRows `shouldBe` 50 + all ((== InboxCompleted) . (^. #status)) inboxRows `shouldBe` True + + it "deduplicates repeated messages within one batch" $ \storeHandle -> do + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction (Tx.sql "CREATE TABLE IF NOT EXISTS inbox_test_counter (message_id TEXT PRIMARY KEY)") + let event = + sampleIntegrationEnvelope + & #messageId + .~ "inbox-batch-dup" + & #source + .~ "batch-ordering" + handler ev = Tx.statement (ev ^. #messageId) inboxTestCounterInsertStmt + Right results <- + Store.runStoreIO storeHandle $ + runInboxTransactionBatch Nothing 3 PreferIntegrationMessageId PersistFullEnvelope [(event, Nothing), (event, Nothing)] handler + results `shouldBe` [Right (InboxProcessed ()), Right InboxDuplicate] + Right rowCount <- + Store.runStoreIO storeHandle $ + Store.runTransaction (Tx.statement () inboxTestCounterCountStmt) + rowCount `shouldBe` 1 + + it "falls back per message when one batch handler throws" $ \storeHandle -> do + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction (Tx.sql "CREATE TABLE IF NOT EXISTS inbox_test_counter (message_id TEXT PRIMARY KEY)") + let events = + [ sampleIntegrationEnvelope + & #messageId + .~ ("inbox-batch-poison-" <> Text.pack (show n)) + & #source + .~ "batch-ordering" + | n <- [1 .. 5 :: Int] + ] + handler ev + | ev ^. #messageId == "inbox-batch-poison-3" = + (pure $! error "batch poison") :: Tx.Transaction () + | otherwise = + Tx.statement (ev ^. #messageId) inboxTestCounterInsertStmt + Right results <- + Store.runStoreIO storeHandle $ + runInboxTransactionBatch Nothing 3 PreferIntegrationMessageId PersistFullEnvelope ((,Nothing) <$> events) handler + case results of + [ Right (InboxProcessed ()) + , Right (InboxProcessed ()) + , Right (InboxHandlerFailed err 1) + , Right (InboxProcessed ()) + , Right (InboxProcessed ()) + ] -> + Text.isInfixOf "batch poison" err `shouldBe` True + other -> expectationFailure ("unexpected batch fallback results: " <> show other) + Right rowCount <- + Store.runStoreIO storeHandle $ + Store.runTransaction (Tx.statement () inboxTestCounterCountStmt) + rowCount `shouldBe` 4 + Right (Just row) <- Store.runStoreIO storeHandle (lookupInbox "batch-ordering" "inbox-batch-poison-3") + row ^. #status `shouldBe` InboxFailed + row ^. #attemptCount `shouldBe` 1 + row ^. #lastError `shouldSatisfy` maybe False (Text.isInfixOf "batch poison") + + it "reports duplicates across batch calls" $ \storeHandle -> do + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction (Tx.sql "CREATE TABLE IF NOT EXISTS inbox_test_counter (message_id TEXT PRIMARY KEY)") + let event = + sampleIntegrationEnvelope + & #messageId + .~ "inbox-batch-existing-dup" + & #source + .~ "batch-ordering" + handler ev = Tx.statement (ev ^. #messageId) inboxTestCounterInsertStmt + Right first <- + Store.runStoreIO storeHandle $ + runInboxTransactionBatch Nothing 3 PreferIntegrationMessageId PersistFullEnvelope [(event, Nothing)] handler + first `shouldBe` [Right (InboxProcessed ())] + Right second <- + Store.runStoreIO storeHandle $ + runInboxTransactionBatch Nothing 3 PreferIntegrationMessageId PersistFullEnvelope [(event, Nothing)] handler + second `shouldBe` [Right InboxDuplicate] + Right rowCount <- + Store.runStoreIO storeHandle $ + Store.runTransaction (Tx.statement () inboxTestCounterCountStmt) + rowCount `shouldBe` 1 + + it "falls back per message when one batch handler condemns the transaction" $ \storeHandle -> do + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction (Tx.sql "CREATE TABLE IF NOT EXISTS inbox_test_counter (message_id TEXT PRIMARY KEY)") + let events = + [ sampleIntegrationEnvelope + & #messageId + .~ ("inbox-batch-condemn-" <> Text.pack (show n)) + & #source + .~ "batch-ordering" + | n <- [1 .. 3 :: Int] + ] + handler ev + | ev ^. #messageId == "inbox-batch-condemn-2" = Tx.condemn + | otherwise = Tx.statement (ev ^. #messageId) inboxTestCounterInsertStmt + Right results <- + Store.runStoreIO storeHandle $ + runInboxTransactionBatch Nothing 3 PreferIntegrationMessageId PersistFullEnvelope ((,Nothing) <$> events) handler + -- The condemned single-message retry reports processed by the + -- documented single-path contract; what matters is that the + -- innocent batch mates actually committed. + results `shouldBe` replicate 3 (Right (InboxProcessed ())) + Right rowCount <- + Store.runStoreIO storeHandle $ + Store.runTransaction (Tx.statement () inboxTestCounterCountStmt) + rowCount `shouldBe` 2 + Right (Just mate1) <- Store.runStoreIO storeHandle (lookupInbox "batch-ordering" "inbox-batch-condemn-1") + Right (Just mate3) <- Store.runStoreIO storeHandle (lookupInbox "batch-ordering" "inbox-batch-condemn-3") + mate1 ^. #status `shouldBe` InboxCompleted + mate3 ^. #status `shouldBe` InboxCompleted + Right condemned <- Store.runStoreIO storeHandle (lookupInbox "batch-ordering" "inbox-batch-condemn-2") + condemned `shouldBe` Nothing + + it "classifies a legacy processing row as InboxInProgress without running the handler" $ \storeHandle -> do + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction (Tx.sql "CREATE TABLE IF NOT EXISTS inbox_test_counter (message_id TEXT PRIMARY KEY)") + let event = + sampleIntegrationEnvelope + & #messageId + .~ "inbox-legacy-processing" + & #source + .~ "ordering" + handler ev = Tx.statement (ev ^. #messageId) inboxTestCounterInsertStmt + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + Tx.sql "INSERT INTO keiro.keiro_inbox (source, dedupe_key, content_type, payload_bytes, status) VALUES ('ordering', 'inbox-legacy-processing', 'application/json', ''::bytea, 'processing')" + Right result <- + Store.runStoreIO storeHandle $ + runInboxTransaction Nothing PreferIntegrationMessageId event Nothing handler + result `shouldBe` Right InboxInProgress + Right rowCount <- + Store.runStoreIO storeHandle $ + Store.runTransaction (Tx.statement () inboxTestCounterCountStmt) + rowCount `shouldBe` 0 + Right (Just row) <- Store.runStoreIO storeHandle (lookupInbox "ordering" "inbox-legacy-processing") + row ^. #status `shouldBe` InboxProcessing + + it "runs the handler once when two workers race the same dedupe key" $ \storeHandle -> do + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction (Tx.sql "CREATE TABLE IF NOT EXISTS inbox_test_counter (message_id TEXT PRIMARY KEY)") + let event = + sampleIntegrationEnvelope + & #messageId + .~ "inbox-race-dup" + & #source + .~ "ordering" + slowHandler ev = do + Tx.statement (ev ^. #messageId) inboxTestCounterInsertStmt + Tx.sql "SELECT pg_sleep(1.5)" + fastHandler ev = Tx.statement (ev ^. #messageId) inboxTestCounterInsertStmt + firstDone <- newEmptyMVar + _ <- forkIO $ do + first <- + Store.runStoreIO storeHandle $ + runInboxTransaction Nothing PreferIntegrationMessageId event Nothing slowHandler + putMVar firstDone first + -- Let the slow worker insert its uncommitted row, then race the + -- same dedupe key: the second insert must block on the unique + -- constraint until the first commits, then classify as duplicate. + threadDelay 400000 + Right second <- + Store.runStoreIO storeHandle $ + runInboxTransaction Nothing PreferIntegrationMessageId event Nothing fastHandler + Right first <- takeMVar firstDone + first `shouldBe` Right (InboxProcessed ()) + second `shouldBe` Right InboxDuplicate + Right rowCount <- + Store.runStoreIO storeHandle $ + Store.runTransaction (Tx.statement () inboxTestCounterCountStmt) + rowCount `shouldBe` 1 + + it "can persist only dedupe columns for successful rows" $ \storeHandle -> do + let kafka = KafkaDeliveryRef "billing.orders.v1" 1 42 + event = + sampleIntegrationEnvelope + & #messageId + .~ "inbox-slim-success" + & #source + .~ "ordering" + & #payloadBytes + .~ "full success payload" + & #attributes + ?~ object ["source" Aeson..= ("slim-test" :: Text)] + handler _ = pure () + Right (Right (InboxProcessed ())) <- + Store.runStoreIO storeHandle $ + runInboxTransactionWith Nothing PersistDedupeOnly PreferIntegrationMessageId event (Just kafka) handler + Right (Just row) <- Store.runStoreIO storeHandle (lookupInbox "ordering" "inbox-slim-success") + row ^. #event . #payloadBytes `shouldBe` "" + row ^. #event . #attributes `shouldBe` Nothing + row ^. #event . #traceContext `shouldBe` Nothing + row ^. #event . #schemaReference `shouldBe` Nothing + row ^. #event . #messageId `shouldBe` "inbox-slim-success" + row ^. #event . #sourceEventId `shouldBe` event ^. #sourceEventId + row ^. #event . #sourceGlobalPosition `shouldBe` event ^. #sourceGlobalPosition + row ^. #event . #causationId `shouldBe` event ^. #causationId + row ^. #event . #correlationId `shouldBe` event ^. #correlationId + row ^. #event . #occurredAt `shouldBe` event ^. #occurredAt + row ^. #kafka `shouldBe` Just kafka + Right redelivery <- + Store.runStoreIO storeHandle $ + runInboxTransactionWith Nothing PersistDedupeOnly PreferIntegrationMessageId event (Just kafka) handler + redelivery `shouldBe` Right InboxDuplicate + + it "keeps full failed rows even when successful rows are dedupe-only" $ \storeHandle -> do + let event = + sampleIntegrationEnvelope + & #messageId + .~ "inbox-slim-failed" + & #source + .~ "ordering" + & #payloadBytes + .~ "full failed payload" + & #attributes + ?~ object ["source" Aeson..= ("failed-slim-test" :: Text)] + handler _ = (pure $! error "slim failure") :: Tx.Transaction () + Right result <- + Store.runStoreIO storeHandle $ + runInboxTransactionWithRetriesWith Nothing 3 PersistDedupeOnly PreferIntegrationMessageId event Nothing handler + case result of + Right (InboxHandlerFailed err 1) -> + Text.isInfixOf "slim failure" err `shouldBe` True + other -> expectationFailure ("expected InboxHandlerFailed, got " <> show other) + Right (Just row) <- Store.runStoreIO storeHandle (lookupInbox "ordering" "inbox-slim-failed") + row ^. #status `shouldBe` InboxFailed + row ^. #event . #payloadBytes `shouldBe` event ^. #payloadBytes + row ^. #event . #attributes `shouldBe` event ^. #attributes + row ^. #event . #traceContext `shouldBe` event ^. #traceContext + row ^. #event . #schemaReference `shouldBe` event ^. #schemaReference + + it "garbage-collects completed rows older than the retention window" $ \storeHandle -> do + let event = + sampleIntegrationEnvelope + & #messageId + .~ "inbox-msg-gc" + & #source + .~ "ordering" + handler _ = pure () + Right (Right (InboxProcessed ())) <- + Store.runStoreIO storeHandle $ + runInboxTransaction Nothing PreferIntegrationMessageId event Nothing handler + -- Backdate the row so it falls outside the retention window. + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + Tx.sql + "UPDATE keiro.keiro_inbox SET completed_at = now() - interval '40 days' WHERE message_id = 'inbox-msg-gc'" + now <- getCurrentTime + Right deleted <- Store.runStoreIO storeHandle (garbageCollectCompleted (nominalDays 30) now) + deleted `shouldBe` 1 + Right rows <- Store.runStoreIO storeHandle (listInbox "ordering") + rows `shouldBe` [] + + describe "Keiro.Inbox.Kafka" $ do + it "reconstructs an integration event from headers and payload" $ do + let envelope = sampleIntegrationEnvelope + headers = integrationHeaders envelope + receivedAt = addUTCTime 60 (envelope ^. #occurredAt) + record = + InboxKafka.KafkaInboundRecord + { topic = "billing.orders.v1" + , partition = 2 + , offset = 113 + , key = Just "order-123" + , payload = envelope ^. #payloadBytes + , headers + , receivedAt + } + case InboxKafka.integrationEventFromKafka record of + Right (rebuilt, kafkaRef) -> do + rebuilt ^. #messageId `shouldBe` envelope ^. #messageId + rebuilt ^. #source `shouldBe` envelope ^. #source + rebuilt ^. #destination `shouldBe` envelope ^. #destination + rebuilt ^. #eventType `shouldBe` envelope ^. #eventType + rebuilt ^. #schemaVersion `shouldBe` envelope ^. #schemaVersion + rebuilt ^. #sourceEventId `shouldBe` envelope ^. #sourceEventId + rebuilt ^. #sourceGlobalPosition `shouldBe` envelope ^. #sourceGlobalPosition + rebuilt ^. #payloadBytes `shouldBe` envelope ^. #payloadBytes + rebuilt ^. #occurredAt `shouldBe` envelope ^. #occurredAt + rebuilt ^. #attributes `shouldBe` envelope ^. #attributes + kafkaRef ^. #topic `shouldBe` "billing.orders.v1" + kafkaRef ^. #partition `shouldBe` 2 + kafkaRef ^. #offset `shouldBe` 113 + Left err -> expectationFailure ("expected Right, got Left " <> show err) + + it "falls back to receivedAt when the occurredAt header is absent" $ do + let envelope = sampleIntegrationEnvelope + receivedAt = addUTCTime 60 (envelope ^. #occurredAt) + headers = filter ((/= "keiro-occurred-at") . Prelude.fst) (integrationHeaders envelope) + record = + InboxKafka.KafkaInboundRecord + { topic = "billing.orders.v1" + , partition = 2 + , offset = 113 + , key = Just "order-123" + , payload = envelope ^. #payloadBytes + , headers + , receivedAt + } + case InboxKafka.integrationEventFromKafka record of + Right (rebuilt, _) -> rebuilt ^. #occurredAt `shouldBe` receivedAt + Left err -> expectationFailure ("expected Right, got Left " <> show err) + + it "rejects malformed occurredAt headers" $ do + let envelope = sampleIntegrationEnvelope + headers = ("keiro-occurred-at", "not-a-time") : filter ((/= "keiro-occurred-at") . Prelude.fst) (integrationHeaders envelope) + record = + InboxKafka.KafkaInboundRecord + { topic = "billing.orders.v1" + , partition = 2 + , offset = 113 + , key = Just "order-123" + , payload = envelope ^. #payloadBytes + , headers + , receivedAt = envelope ^. #occurredAt + } + InboxKafka.integrationEventFromKafka record + `shouldBe` Left (InboxKafka.InvalidTimeHeader "keiro-occurred-at" "not-a-time") + + it "reports MissingHeader for an essential header" $ do + let envelope = sampleIntegrationEnvelope + headers = filter ((/= "keiro-message-id") . Prelude.fst) (integrationHeaders envelope) + record = + InboxKafka.KafkaInboundRecord + { topic = "billing.orders.v1" + , partition = 0 + , offset = 0 + , key = Nothing + , payload = envelope ^. #payloadBytes + , headers + , receivedAt = envelope ^. #occurredAt + } + InboxKafka.integrationEventFromKafka record + `shouldBe` Left (InboxKafka.MissingHeader "keiro-message-id") + + it "withConsumerSpan parents the consumer span under an upstream producer span via W3C headers" $ do + (processor, spansRef) <- inMemoryListExporter + provider <- createTracerProvider [processor] emptyTracerProviderOptions + let tracer = makeTracer provider "keiro-test" tracerOptions + -- Clear the baked-in TraceContext on the sample so the only + -- `traceparent` on the wire comes from the active producer + -- span (via `injectTraceContext`). + envelope = sampleIntegrationEnvelope & #traceContext .~ Nothing + producerRecord = OutboxKafka.integrationEventToKafkaRecord envelope + producerHeadersText <- + Telemetry.withProducerSpan (Just tracer) envelope producerRecord $ \_ -> do + let baseHeaders = + [(TE.decodeUtf8 n, TE.decodeUtf8 v) | (n, v) <- producerRecord ^. #headers] + Telemetry.injectTraceContext baseHeaders + -- Build the inbound record the consumer would receive and open the + -- consumer span around a no-op body. + now <- getCurrentTime + let inbound = + InboxKafka.KafkaInboundRecord + { topic = envelope ^. #destination + , partition = 7 + , offset = 42 + , key = envelope ^. #key + , payload = envelope ^. #payloadBytes + , headers = producerHeadersText + , receivedAt = now + } + Telemetry.withConsumerSpan (Just tracer) (Just "billing-cg") inbound (Just envelope) $ \_ -> + pure () + _ <- shutdownTracerProvider provider Nothing + spans <- traverse captureSpan =<< readIORef spansRef + length spans `shouldBe` 2 + let findByName needle = case [s | s <- spans, csName s == needle] of + (s : _) -> s + [] -> error ("no span captured with name=" <> Text.unpack needle) + producerSp = findByName ("send " <> envelope ^. #destination) + consumerSp = findByName ("process " <> envelope ^. #destination) + -- Same trace id end-to-end (cross-process parenting). + traceId (csContext producerSp) `shouldBe` traceId (csContext consumerSp) + -- Consumer's parent is the producer span. + case csParent consumerSp of + Nothing -> expectationFailure "consumer span has no parent" + Just parent -> do + parentCtx <- getSpanContext parent + spanId parentCtx `shouldBe` spanId (csContext producerSp) + -- Consumer span carries the expected attributes. + show (csKind consumerSp) `shouldBe` "Consumer" + textAttr (csAttributes consumerSp) "messaging.system" `shouldBe` Just "kafka" + textAttr (csAttributes consumerSp) "messaging.operation.type" `shouldBe` Just "process" + textAttr (csAttributes consumerSp) "messaging.destination.name" + `shouldBe` Just (envelope ^. #destination) + textAttr (csAttributes consumerSp) "messaging.destination.partition.id" + `shouldBe` Just "7" + textAttr (csAttributes consumerSp) "messaging.consumer.group.name" + `shouldBe` Just "billing-cg" + textAttr (csAttributes consumerSp) "messaging.message.id" + `shouldBe` Just (envelope ^. #messageId) + + describe "Keiro cross-context Kafka integration" $ around (withFreshStores2 fixture) $ do + it "publishes an Ordering integration event and runs the Billing handler exactly once across duplicate deliveries" $ \(ordering, billing) -> do + Right () <- + Store.runStoreIO billing $ + Store.runTransaction (Tx.sql "CREATE TABLE IF NOT EXISTS billing_received_orders (order_id TEXT PRIMARY KEY, quantity BIGINT NOT NULL)") + topic <- newKafkaTopic + -- Ordering side: enqueue an outbox row representing a published event. + let orderingEvent = orderSubmittedEnvelope "order-aaa" 7 "msg-aaa" + oid = OutboxId outboxUuid1 + Right () <- + Store.runStoreIO ordering $ + Store.runTransaction (enqueueIntegrationEventTx oid orderingEvent) + -- Run the publisher worker: push records to the in-process topic. + Right pubSummary1 <- + Store.runStoreIO ordering $ + publishClaimedOutbox (perRow (kafkaTopicPublish topic)) defaultPublishOptions Nothing + pubSummary1 ^. #published `shouldBe` 1 + -- Billing side: consume from the topic. + records1 <- drainKafkaTopic topic + record1 <- case records1 of + [r] -> pure r + other -> expectationFailure ("expected 1 record, got " <> show (length other)) *> error "unreachable" + Right consumed1 <- + Store.runStoreIO billing $ + consumeAndApply record1 billingReactionHandler + consumed1 `shouldBe` ConsumeApplied (InboxProcessed ()) + Right rowCount1 <- + Store.runStoreIO billing $ + Store.runTransaction (Tx.statement () billingReceivedOrdersCountStmt) + rowCount1 `shouldBe` 1 + + -- Simulate Kafka redelivery: pretend the same Kafka record was + -- delivered again at a different offset. The producer also retries + -- (the outbox flips back to pending and the worker republishes). + let redelivered = redeliverWithDifferentOffset record1 + Right consumed2 <- + Store.runStoreIO billing $ + consumeAndApply redelivered billingReactionHandler + consumed2 `shouldBe` ConsumeApplied InboxDuplicate + Right rowCount2 <- + Store.runStoreIO billing $ + Store.runTransaction (Tx.statement () billingReceivedOrdersCountStmt) + rowCount2 `shouldBe` 1 + + it "preserves per-partition ordering for two events sharing a Kafka key" $ \(ordering, billing) -> do + Right () <- + Store.runStoreIO billing $ + Store.runTransaction (Tx.sql "CREATE TABLE IF NOT EXISTS billing_received_orders (order_id TEXT PRIMARY KEY, quantity BIGINT NOT NULL)") + Right () <- + Store.runStoreIO billing $ + Store.runTransaction (Tx.sql "CREATE TABLE IF NOT EXISTS billing_event_log (seq BIGSERIAL PRIMARY KEY, source TEXT NOT NULL, event_type TEXT NOT NULL, order_id TEXT NOT NULL)") + topic <- newKafkaTopic + -- Two events for the same order key. + let submittedEnv = orderSubmittedEnvelope "order-bbb" 4 "msg-bbb-1" + cancelledEnv = orderCancelledEnvelope "order-bbb" "msg-bbb-2" + submittedId = OutboxId outboxUuid1 + cancelledId = OutboxId outboxUuid2 + Right () <- + Store.runStoreIO ordering $ + Store.runTransaction (enqueueIntegrationEventTx submittedId submittedEnv) + Right () <- + Store.runStoreIO ordering $ + Store.runTransaction (enqueueIntegrationEventTx cancelledId cancelledEnv) + -- Run-claiming lets a same-key contiguous run drain in one pass. + let drainOnce = + publishClaimedOutbox + (perRow (kafkaTopicPublish topic)) + (defaultPublishOptions & #backoff .~ ConstantBackoff 0) + Nothing + Right s1 <- Store.runStoreIO ordering drainOnce + Right s2 <- Store.runStoreIO ordering drainOnce + (s1 ^. #published) + (s2 ^. #published) `shouldBe` 2 + records <- drainKafkaTopic topic + length records `shouldBe` 2 + -- Apply both records to billing in delivery order. + for_ records $ \record -> do + Right consumed <- + Store.runStoreIO billing $ + consumeAndApply record (loggingReactionHandler "billing") + case consumed of + ConsumeApplied (InboxProcessed ()) -> pure () + other -> expectationFailure ("expected processed, got " <> show other) + Right events <- + Store.runStoreIO billing $ + Store.runTransaction (Tx.statement () billingEventLogStmt) + events `shouldBe` [("OrderSubmitted", "order-bbb"), ("OrderCancelled", "order-bbb")] + + it "head-of-line blocks a same-key successor when the first send fails repeatedly until the first row reaches dead status" $ \(ordering, billing) -> do + Right () <- + Store.runStoreIO billing $ + Store.runTransaction (Tx.sql "CREATE TABLE IF NOT EXISTS billing_received_orders (order_id TEXT PRIMARY KEY, quantity BIGINT NOT NULL)") + topic <- newKafkaTopic + let submittedEnv = orderSubmittedEnvelope "order-ccc" 1 "msg-ccc-1" + cancelledEnv = orderCancelledEnvelope "order-ccc" "msg-ccc-2" + firstId = OutboxId outboxUuid1 + secondId = OutboxId outboxUuid2 + Right () <- + Store.runStoreIO ordering $ + Store.runTransaction (enqueueIntegrationEventTx firstId submittedEnv) + Right () <- + Store.runStoreIO ordering $ + Store.runTransaction (enqueueIntegrationEventTx secondId cancelledEnv) + -- Failing publish for the first row, success for any other. + let publish row + | row ^. #outboxId == firstId = + pure (PublishFailed "simulated broker reject") + | otherwise = do + kafkaTopicAccept topic row + pure PublishSucceeded + deadOpts = + defaultPublishOptions + & #batchSize + .~ 1 + & #backoff + .~ ConstantBackoff 0 + & #maxAttempts + .~ 2 + -- This test drives the pre-M3 sequential failure/dead-letter path + -- with one-row batches. M3 adds suffix skipping for larger claimed + -- same-key runs. + -- First pass: the first row attempts once and fails; the second is + -- outside the one-row claim window. + Right pass1 <- Store.runStoreIO ordering (publishClaimedOutbox (perRow publish) deadOpts Nothing) + pass1 ^. #retried `shouldBe` 1 + pass1 ^. #published `shouldBe` 0 + -- Second pass crosses maxAttempts and dead-letters the first row. + Right pass2 <- Store.runStoreIO ordering (publishClaimedOutbox (perRow publish) deadOpts Nothing) + pass2 ^. #dead `shouldBe` 1 + Right (Just firstRow) <- Store.runStoreIO ordering (lookupOutbox firstId) + firstRow ^. #status `shouldBe` OutboxDead + -- With the first row dead, the second becomes claimable and publishes. + Right pass3 <- Store.runStoreIO ordering (publishClaimedOutbox (perRow publish) deadOpts Nothing) + pass3 ^. #published `shouldBe` 1 + Right (Just secondRow) <- Store.runStoreIO ordering (lookupOutbox secondId) + secondRow ^. #status `shouldBe` OutboxSent + -- Billing only sees the second event. + records <- drainKafkaTopic topic + record <- case records of + [r] -> pure r + other -> expectationFailure ("expected 1 record, got " <> show (length other)) *> error "unreachable" + Right consumed <- + Store.runStoreIO billing $ + consumeAndApply record billingReactionHandler + consumed `shouldBe` ConsumeApplied (InboxProcessed ()) + + describe "Keiro.Integration.Event" $ do + it "round-trips a JSON envelope through encode and decode" $ do + let envelope = sampleIntegrationEnvelope + payload = OrderSubmittedPayload "order-123" 5 + encoded = encodeJsonIntegrationEvent envelope payload + decodeJsonIntegrationEvent encoded `shouldBe` Right payload + + it "preserves identity and routing through encode" $ do + let envelope = sampleIntegrationEnvelope + encoded = encodeJsonIntegrationEvent envelope (OrderSubmittedPayload "order-123" 5) + encoded ^. #messageId `shouldBe` envelope ^. #messageId + encoded ^. #source `shouldBe` "ordering" + encoded ^. #destination `shouldBe` "billing.orders.v1" + encoded ^. #key `shouldBe` Just "order-123" + encoded ^. #eventType `shouldBe` "OrderSubmitted" + encoded ^. #schemaVersion `shouldBe` 1 + encoded ^. #contentType `shouldBe` ApplicationJson + + it "emits the canonical wire headers" $ do + let envelope = sampleIntegrationEnvelope + headers = integrationHeaders envelope + Prelude.lookup headerMessageId headers `shouldBe` Just (envelope ^. #messageId) + Prelude.lookup headerSchemaVersion headers `shouldBe` Just "1" + Prelude.lookup headerContentType headers `shouldBe` Just "application/json" + Prelude.lookup headerSchemaSubject headers `shouldBe` Just "billing.orders.v1.OrderSubmitted" + Prelude.lookup headerSourceEventId headers `shouldBe` Just "018f0f18-17aa-7000-8000-000000000003" + Prelude.lookup headerSourceGlobalPosition headers `shouldBe` Just "42" + Prelude.lookup headerTraceParent headers + `shouldBe` Just "00-0af7651916cd43dd8448eb211c80319c-b7ad6b7169203331-01" + + it "preserves a different content type without claiming JSON" $ do + let envelope = + sampleIntegrationEnvelope + & #contentType + .~ OtherContentType "application/vnd.apache.avro.binary" + & #payloadBytes + .~ "\x00\x01\x02" + headers = integrationHeaders envelope + Prelude.lookup headerContentType headers + `shouldBe` Just "application/vnd.apache.avro.binary" + decodeJsonIntegrationEvent envelope + `shouldBe` ( Left (IntegrationEvent.UnsupportedContentType "application/vnd.apache.avro.binary") :: + Either IntegrationEvent.IntegrationEventError OrderSubmittedPayload + ) + + it "reports malformed JSON payloads as decode errors instead of throwing" $ do + let envelope = + sampleIntegrationEnvelope + & #payloadBytes + .~ "{not-json" + case decodeJsonIntegrationEvent envelope :: Either IntegrationEvent.IntegrationEventError OrderSubmittedPayload of + Left (IntegrationEvent.MalformedPayload _) -> pure () + other -> expectationFailure ("expected MalformedPayload, got " <> show other) + + it "reports a JSON value that does not satisfy the target type as DecodeFailed" $ do + let envelope = + sampleIntegrationEnvelope + & #payloadBytes + .~ "{\"orderId\":\"order-123\"}" + case decodeJsonIntegrationEvent envelope :: Either IntegrationEvent.IntegrationEventError OrderSubmittedPayload of + Left (IntegrationEvent.DecodeFailed _) -> pure () + other -> expectationFailure ("expected DecodeFailed, got " <> show other) + + it "parses content-type headers back to the canonical type" $ do + parseContentType "application/json" `shouldBe` ApplicationJson + parseContentType "Application/JSON" `shouldBe` ApplicationJson + parseContentType "application/json; charset=utf-8" `shouldBe` ApplicationJson + parseContentType "APPLICATION/JSON ; CHARSET=UTF-8" `shouldBe` ApplicationJson + parseContentType "application/vnd.apache.avro.binary" + `shouldBe` OtherContentType "application/vnd.apache.avro.binary" + + it "preserves the payload bytes through integrationPayload" $ do + let envelope = sampleIntegrationEnvelope + encoded = encodeJsonIntegrationEvent envelope (OrderSubmittedPayload "order-123" 5) + integrationPayload encoded `shouldBe` (encoded ^. #payloadBytes) + + describe "Keiro.Telemetry" $ do + it "is a pass-through under a noop (Nothing) tracer" $ do + counter <- newIORef (0 :: Int) + let envelope = sampleIntegrationEnvelope + record = OutboxKafka.integrationEventToKafkaRecord envelope + result <- + Telemetry.withProducerSpan Nothing envelope record $ \mSpan -> do + atomicModifyIORef' counter (\n -> (n + 1, ())) + pure (mSpan, "ok" :: Text) + callsAfter <- readIORef counter + callsAfter `shouldBe` (1 :: Int) + snd result `shouldBe` "ok" + fst result `shouldSatisfy` isNothing + + it "re-exports AttributeKeys whose textual payload matches the spec name" $ do + attrKeyText Telemetry.messaging_operation_type `shouldBe` "messaging.operation.type" + attrKeyText Telemetry.messaging_operation_name `shouldBe` "messaging.operation.name" + attrKeyText Telemetry.messaging_destination_partition_id `shouldBe` "messaging.destination.partition.id" + attrKeyText Telemetry.messaging_consumer_group_name `shouldBe` "messaging.consumer.group.name" + attrKeyText Telemetry.messaging_client_id `shouldBe` "messaging.client.id" + attrKeyTextInt64 Telemetry.messaging_kafka_offset `shouldBe` "messaging.kafka.offset" + attrKeyText Telemetry.db_system_name `shouldBe` "db.system.name" + attrKeyText Telemetry.db_namespace `shouldBe` "db.namespace" + attrKeyText Telemetry.db_collection_name `shouldBe` "db.collection.name" + attrKeyText Telemetry.db_operation_name `shouldBe` "db.operation.name" + attrKeyText Telemetry.keiro_stream_name `shouldBe` "keiro.stream.name" + attrKeyTextInt64 Telemetry.keiro_retry_attempt `shouldBe` "keiro.retry.attempt" + attrKeyTextInt64 Telemetry.keiro_events_appended `shouldBe` "keiro.events.appended" + attrKeyText Telemetry.keiro_replay_divergence `shouldBe` "keiro.replay.divergence" + + it "extracts a TraceContext from a W3C traceparent header pair" $ do + let traceparent = "00-0af7651916cd43dd8448eb211c80319c-b7ad6b7169203331-01" + tracestate = "vendor1=value1" + hs = [(headerTraceParent, traceparent), ("tracestate", tracestate)] + Telemetry.traceContextFromHeaders hs + `shouldBe` Just (TraceContext traceparent (Just tracestate)) + + it "returns Nothing when the traceparent header is missing" $ do + Telemetry.traceContextFromHeaders [("content-type", "application/json")] + `shouldBe` Nothing + + it "injectTraceContext is a no-op when no span is active on the thread" $ do + let baseline = [("content-type", "application/json")] + injected <- Telemetry.injectTraceContext baseline + injected `shouldBe` baseline + + it "traceContextFromCurrentSpan returns Nothing outside any span" $ do + tc <- Telemetry.traceContextFromCurrentSpan + tc `shouldBe` Nothing + + describe "Keiro.Workflow" $ around (withFreshStore fixture) $ do + it "journals each step once, returns Completed, and runs each side effect once" $ \storeHandle -> do + counter <- newIORef (0 :: Int) + let name = WorkflowName "demo" + wid = WorkflowId "demo-1" + result <- Store.runStoreIO storeHandle $ runWorkflow name wid (demoWorkflow counter) + result `shouldBe` Right (Completed (1, 2)) + sideEffects <- readIORef counter + sideEffects `shouldBe` 2 + Right recorded <- + Store.runStoreIO storeHandle $ + Store.readStreamForward (StreamName "wf:demo-demo-1") (StreamVersion 0) 10 + Vector.length recorded `shouldBe` 3 + traverse (decodeRecorded workflowJournalCodec) (Vector.toList recorded) + `shouldSatisfy` \case + Right [StepRecorded "first" _ _, StepRecorded "second" _ _, WorkflowCompleted _] -> True + _ -> False + + it "replays recorded steps without re-running their side effects" $ \storeHandle -> do + counter <- newIORef (0 :: Int) + let name = WorkflowName "replay" + wid = WorkflowId "r-1" + first <- Store.runStoreIO storeHandle $ runWorkflow name wid (demoWorkflow counter) + first `shouldBe` Right (Completed (1, 2)) + afterFirst <- readIORef counter + afterFirst `shouldBe` 2 + -- A second run with the same id is exactly the crash-restart scenario. + second <- Store.runStoreIO storeHandle $ runWorkflow name wid (demoWorkflow counter) + second `shouldBe` Right (Completed (1, 2)) + afterSecond <- readIORef counter + afterSecond `shouldBe` 2 + -- The deterministic ids and pre-load gating leave the journal at 3 events. + Right recorded <- + Store.runStoreIO storeHandle $ + Store.readStreamForward (StreamName "wf:replay-r-1") (StreamVersion 0) 10 + Vector.length recorded `shouldBe` 3 + + it "reuses the recorded result for a repeated step name in one run" $ \storeHandle -> do + counter <- newIORef (0 :: Int) + let name = WorkflowName "samename" + wid = WorkflowId "s-1" + duplicateStepWorkflow = do + a <- step (StepName "dup") (liftIO (incrementAndRead counter)) + b <- step (StepName "dup") (liftIO (incrementAndRead counter)) + pure (a, b) + result <- Store.runStoreIO storeHandle $ runWorkflow name wid duplicateStepWorkflow + result `shouldBe` Right (Completed (1, 1)) + sideEffects <- readIORef counter + sideEffects `shouldBe` 1 + + it "suspends on an unresolved awaitStep, journaling no completion" $ \storeHandle -> do + let name = WorkflowName "awaiter" + wid = WorkflowId "a-1" + result <- Store.runStoreIO storeHandle $ runWorkflow name wid neverArmingWorkflow + result `shouldBe` Right Suspended + Right recorded <- + Store.runStoreIO storeHandle $ + Store.readStreamForward (StreamName "wf:awaiter-a-1") (StreamVersion 0) 10 + Vector.length recorded `shouldBe` 0 + + it "resumes and completes once an awaited step is externally completed" $ \storeHandle -> do + let name = WorkflowName "awaiter2" + wid = WorkflowId "a-2" + suspended <- Store.runStoreIO storeHandle $ runWorkflow name wid neverArmingWorkflow + suspended `shouldBe` Right Suspended + -- Simulate a wake source recording the awaited step's resolution. + Right () <- Store.runStoreIO storeHandle $ do + now <- liftIO getCurrentTime + appendJournalEntry name wid (StepRecorded "awk:test" (toJSON (42 :: Int)) now) + resumed <- Store.runStoreIO storeHandle $ runWorkflow name wid neverArmingWorkflow + resumed `shouldBe` Right (Completed 42) + Right recorded <- + Store.runStoreIO storeHandle $ + Store.readStreamForward (StreamName "wf:awaiter2-a-2") (StreamVersion 0) 10 + traverse (decodeRecorded workflowJournalCodec) (Vector.toList recorded) + `shouldSatisfy` \case + Right [StepRecorded "awk:test" _ _, WorkflowCompleted _] -> True + _ -> False + + it "treats a duplicate external journal append as idempotent" $ \storeHandle -> do + let name = WorkflowName "duplicate-append" + wid = WorkflowId "da-1" + stepKey = "awk:test" + eventAt t = StepRecorded stepKey (toJSON (42 :: Int)) t + now <- getCurrentTime + Right firstId <- + Store.runStoreIO storeHandle $ + appendJournalEntryReturningId name wid (eventAt now) + secondResult <- + Store.runStoreIO storeHandle $ + appendJournalEntryReturningId name wid (eventAt now) + secondId <- case secondResult of + Right value -> pure value + Left err -> expectationFailure ("expected idempotent duplicate append, got " <> show err) *> error "unreachable" + secondId `shouldBe` firstId + Right indexed <- Store.runStoreIO storeHandle $ loadStepIndex name wid 0 + Map.lookup stepKey indexed `shouldBe` Just (toJSON (42 :: Int)) + Right recorded <- + Store.runStoreIO storeHandle $ + Store.readStreamForward (StreamName "wf:duplicate-append-da-1") (StreamVersion 0) 10 + Vector.length recorded `shouldBe` 1 + + it "returns the journaled value when another writer records the same step mid-flight" $ \storeHandle -> do + let name = WorkflowName "journal-race" + wid = WorkflowId "jr-1" + body = + step (StepName "raced") $ do + now <- liftIO getCurrentTime + appendJournalEntry name wid (StepRecorded "raced" (toJSON ("winner" :: Text)) now) + pure ("loser" :: Text) + outcome <- Store.runStoreIO storeHandle $ runWorkflow name wid body + outcome `shouldBe` Right (Completed "winner") + Right recorded <- + Store.runStoreIO storeHandle $ + Store.readStreamForward (StreamName "wf:journal-race-jr-1") (StreamVersion 0) 10 + traverse (decodeRecorded workflowJournalCodec) (Vector.toList recorded) + `shouldSatisfy` \case + Right [StepRecorded "raced" value _, WorkflowCompleted _] -> value == toJSON ("winner" :: Text) + _ -> False + + it "returns the JSON round-trip of a fresh step result" $ \storeHandle -> do + let name = WorkflowName "roundtrip-step" + wid = WorkflowId "rs-1" + body = step (StepName "approx") (pure (Approx 1.7)) + first <- Store.runStoreIO storeHandle $ runWorkflow name wid body + first `shouldBe` Right (Completed (Approx 2.0)) + replay <- Store.runStoreIO storeHandle $ runWorkflow name wid body + replay `shouldBe` Right (Completed (Approx 2.0)) + + it "throws WorkflowStepDecodeError on the first run when the recorded result cannot decode" $ \storeHandle -> do + let name = WorkflowName "bad-roundtrip" + wid = WorkflowId "br-1" + body = step (StepName "bad") (pure RejectingRoundTrip) + Store.runStoreIO storeHandle (runWorkflow name wid body) + `shouldThrow` \case + WorkflowStepDecodeError key _ -> key == "bad" + _ -> False + Store.runStoreIO storeHandle (stepExists name wid 0 "bad") + `shouldReturn` Right True + + it "discovers unfinished workflows via the step index" $ \storeHandle -> do + counter <- newIORef (0 :: Int) + Right (Completed _) <- + Store.runStoreIO storeHandle $ + runWorkflow (WorkflowName "done") (WorkflowId "d-1") (demoWorkflow counter) + Right Suspended <- + Store.runStoreIO storeHandle $ + runWorkflow (WorkflowName "pending") (WorkflowId "p-1") (stepThenAwaitWorkflow counter) + now <- getCurrentTime + Right unfinished <- Store.runStoreIO storeHandle (findUnfinishedWorkflowIds now) + unfinished `shouldBe` [("p-1", "pending")] + + describe "Keiro.Workflow instance table" $ around (withFreshStore fixture) $ do + it "creates and completes a workflow instance row transactionally with the journal" $ \storeHandle -> do + counter <- newIORef (0 :: Int) + let name = WorkflowName "inst-complete" + wid = WorkflowId "ic-1" + Right (Completed _) <- Store.runStoreIO storeHandle $ runWorkflow name wid (demoWorkflow counter) + Right (Just row) <- Store.runStoreIO storeHandle $ Instance.lookupInstance name wid + row ^. #workflowId `shouldBe` "ic-1" + row ^. #workflowName `shouldBe` "inst-complete" + row ^. #generation `shouldBe` 0 + row ^. #status `shouldBe` Instance.WfCompleted + row ^. #completedAt `shouldSatisfy` isJust + + it "records suspended status for workflows that park before journaling" $ \storeHandle -> do + let name = WorkflowName "inst-suspended" + wid = WorkflowId "is-1" + Right Suspended <- Store.runStoreIO storeHandle $ runWorkflow name wid neverArmingWorkflow + Right (Just row) <- Store.runStoreIO storeHandle $ Instance.lookupInstance name wid + row ^. #status `shouldBe` Instance.WfSuspended + row ^. #generation `shouldBe` 0 + row ^. #completedAt `shouldBe` Nothing + + it "creates child instance rows at spawn time and flips them to cancelled" $ \storeHandle -> do + let childWid = WorkflowId "inst-child" + childName = WorkflowName "ship" + Right Suspended <- + Store.runStoreIO storeHandle $ + runWorkflow (WorkflowName "inst-parent") (WorkflowId "ip-1") (parentWorkflow childWid) + Right (Just spawned) <- Store.runStoreIO storeHandle $ Instance.lookupInstance childName childWid + spawned ^. #status `shouldBe` Instance.WfRunning + Right True <- Store.runStoreIO storeHandle $ cancelChild (ChildHandle childName childWid) + Right (Just cancelledRow) <- Store.runStoreIO storeHandle $ Instance.lookupInstance childName childWid + cancelledRow ^. #status `shouldBe` Instance.WfCancelled + cancelledRow ^. #completedAt `shouldSatisfy` isJust + + it "bumps the instance generation when continueAsNew rotates" $ \storeHandle -> do + counter <- newIORef (0 :: Int) + let name = WorkflowName "inst-rotate" + wid = WorkflowId "ir-1" + Right ContinuedAsNew <- + Store.runStoreIO storeHandle $ + runWorkflow name wid (rollingTotal counter 1 2) + Right (Just row) <- Store.runStoreIO storeHandle $ Instance.lookupInstance name wid + row ^. #generation `shouldBe` 1 + row ^. #status `shouldBe` Instance.WfRunning + + it "does not let a late append resurrect a terminal instance row" $ \storeHandle -> do + counter <- newIORef (0 :: Int) + let name = WorkflowName "inst-terminal" + wid = WorkflowId "it-1" + Right (Completed _) <- Store.runStoreIO storeHandle $ runWorkflow name wid (demoWorkflow counter) + now <- getCurrentTime + Right () <- + Store.runStoreIO storeHandle $ + appendJournalEntry name wid (StepRecorded "late" (toJSON True) now) + Right (Just row) <- Store.runStoreIO storeHandle $ Instance.lookupInstance name wid + row ^. #status `shouldBe` Instance.WfCompleted + + it "discovers unfinished workflows from the instance table" $ \storeHandle -> do + counter <- newIORef (0 :: Int) + let completedName = WorkflowName "discover-completed" + cancelledName = WorkflowName "discover-cancelled" + crashedName = WorkflowName "discover-crashed" + rotatedName = WorkflowName "discover-rotated" + Right (Completed _) <- + Store.runStoreIO storeHandle $ + runWorkflow completedName (WorkflowId "done") (demoWorkflow counter) + cancelledAt <- getCurrentTime + Right () <- + Store.runStoreIO storeHandle $ + appendJournalEntry cancelledName (WorkflowId "cancelled") (WorkflowCancelled cancelledAt) + Left (_ :: SimulatedCrash) <- + try $ + Store.runStoreIO storeHandle $ + runWorkflow crashedName (WorkflowId "crashed") (crashAfterStep1 counter) + Right ContinuedAsNew <- + Store.runStoreIO storeHandle $ + runWorkflow rotatedName (WorkflowId "rotated") (rollingTotal counter 1 2) + now <- getCurrentTime + Right unfinished <- Store.runStoreIO storeHandle (findUnfinishedWorkflowIds now) + unfinished + `shouldBe` [ ("crashed", "discover-crashed") + , ("rotated", "discover-rotated") + ] + + describe "Keiro.Workflow snapshots" $ around (withFreshStore fixture) $ do + it "does not fail committed workflow steps when snapshot writes fail" $ \storeHandle -> do + (exporter, metricsRef) <- inMemoryMetricExporter + (provider, _env) <- + createMeterProvider + emptyMaterializedResources + defaultSdkMeterProviderOptions{metricExporter = Just exporter} + meter <- getMeter provider Telemetry.keiroInstrumentationLibrary + keiroMetrics <- Telemetry.newKeiroMetrics meter + let opts = + defaultWorkflowRunOptions + & #snapshotPolicy + .~ Every 2 + & #metrics + ?~ keiroMetrics + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + Tx.sql "ALTER TABLE keiro.keiro_snapshots ADD CONSTRAINT keiro_snapshots_no_writes CHECK (false) NOT VALID" + counter <- newIORef (0 :: Int) + result <- + Store.runStoreIO storeHandle $ + runWorkflowWith opts (WorkflowName "snap-write-failure") (WorkflowId "wf1") (countingSixSteps counter) + result `shouldBe` Right (Completed [1, 2, 3, 4, 5, 6]) + Right journal <- + Store.runStoreIO storeHandle $ + Store.readStreamForward (StreamName "wf:snap-write-failure-wf1") (StreamVersion 0) 100 + Vector.length journal `shouldBe` 7 + Right snapshotVersionDuringFailure <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + Tx.statement "wf:snap-write-failure-wf1" snapshotVersionForStreamStmt + snapshotVersionDuringFailure `shouldBe` Nothing + _ <- forceFlushMeterProvider provider Nothing + exported <- readIORef metricsRef + lookup "keiro.snapshot.write.failures" (flattenScalarPoints exported) `shouldBe` Just (IntNumber 3) + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + Tx.sql "ALTER TABLE keiro.keiro_snapshots DROP CONSTRAINT keiro_snapshots_no_writes" + recoveryCounter <- newIORef (0 :: Int) + recovery <- + Store.runStoreIO storeHandle $ + runWorkflowWith opts (WorkflowName "snap-write-recovery") (WorkflowId "wf2") (countingSixSteps recoveryCounter) + recovery `shouldBe` Right (Completed [1, 2, 3, 4, 5, 6]) + Right snapshotVersionAfterRecovery <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + Tx.statement "wf:snap-write-recovery-wf2" snapshotVersionForStreamStmt + snapshotVersionAfterRecovery `shouldBe` Just (StreamVersion 6) + + -- Validation (a): a snapshot row appears at the expected version and + -- decodes to the full accumulated step map. + it "writes a snapshot of the accumulated step map after Every 2 fires" $ \storeHandle -> do + counter <- newIORef (0 :: Int) + let name = WorkflowName "snap" + wid = WorkflowId "w1" + result <- + Store.runStoreIO storeHandle $ + runWorkflowWith + (defaultWorkflowRunOptions & #snapshotPolicy .~ Every 2) + name + wid + (countingSixSteps counter) + result `shouldBe` Right (Completed [1, 2, 3, 4, 5, 6]) + -- Every 2 fired at versions 2, 4, 6; the upsert keeps the highest (6). + Right snapVersion <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + Tx.statement "wf:snap-w1" snapshotVersionForStreamStmt + snapVersion `shouldBe` Just (StreamVersion 6) + -- and the row decodes to the six-entry accumulated map. + Right mSeed <- Store.runStoreIO storeHandle $ loadWorkflowSnapshot (StreamName "wf:snap-w1") + case mSeed of + Just (m, v) -> do + v `shouldBe` StreamVersion 6 + Map.keys m `shouldBe` ["s1", "s2", "s3", "s4", "s5", "s6"] + Nothing -> expectationFailure "expected a workflow snapshot row" + + -- The OnTerminal completion-site wiring: only the final WorkflowCompleted + -- append (version 7) triggers the snapshot. + it "writes a terminal snapshot under OnTerminal at the completion version" $ \storeHandle -> do + counter <- newIORef (0 :: Int) + let name = WorkflowName "term" + wid = WorkflowId "tm1" + result <- + Store.runStoreIO storeHandle $ + runWorkflowWith + (defaultWorkflowRunOptions & #snapshotPolicy .~ OnTerminal) + name + wid + (countingSixSteps counter) + result `shouldBe` Right (Completed [1, 2, 3, 4, 5, 6]) + Right snapVersion <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + Tx.statement "wf:term-tm1" snapshotVersionForStreamStmt + snapVersion `shouldBe` Just (StreamVersion 7) + + -- Validation (b): re-hydration reads only the tail after the snapshot + -- version, and the journaled steps short-circuit (the counter stays put). + it "reads only the tail after the snapshot version on re-hydration" $ \storeHandle -> do + counter <- newIORef (0 :: Int) + let name = WorkflowName "tail" + wid = WorkflowId "t1" + opts = defaultWorkflowRunOptions & #snapshotPolicy .~ Every 2 + first <- Store.runStoreIO storeHandle $ runWorkflowWith opts name wid (countingSixSteps counter) + first `shouldBe` Right (Completed [1, 2, 3, 4, 5, 6]) + afterFirst <- readIORef counter + afterFirst `shouldBe` 6 + -- A full version-0 replay would read every journal event... + Right full <- + Store.runStoreIO storeHandle $ + Store.readStreamForward (StreamName "wf:tail-t1") (StreamVersion 0) 100 + Vector.length full `shouldBe` 7 -- six StepRecorded + one WorkflowCompleted + -- ...whereas the runtime seeds from the snapshot and reads only the tail. + Right (Just (seedMap, StreamVersion sv)) <- + Store.runStoreIO storeHandle $ loadWorkflowSnapshot (StreamName "wf:tail-t1") + Map.size seedMap `shouldBe` 6 + Right tailEvents <- + Store.runStoreIO storeHandle $ + Store.readStreamForward (StreamName "wf:tail-t1") (StreamVersion sv) 100 + Vector.length tailEvents `shouldSatisfy` (< Vector.length full) + Vector.length tailEvents `shouldBe` 1 -- only the WorkflowCompleted at v7 + -- Re-hydration completes from the seed without re-running any step. + second <- Store.runStoreIO storeHandle $ runWorkflowWith opts name wid (countingSixSteps counter) + second `shouldBe` Right (Completed [1, 2, 3, 4, 5, 6]) + afterSecond <- readIORef counter + afterSecond `shouldBe` 6 + + -- Validation (c): a Never run and an Every 2 run produce identical results + -- and identical journals, and the snapshot seed equals a full replay. + it "produces identical results and journals under Never and Every 2" $ \storeHandle -> do + counterN <- newIORef (0 :: Int) + counterE <- newIORef (0 :: Int) + neverRes <- + Store.runStoreIO storeHandle $ + runWorkflowWith + (defaultWorkflowRunOptions & #snapshotPolicy .~ Never) + (WorkflowName "corr-never") + (WorkflowId "c1") + (countingSixSteps counterN) + everyRes <- + Store.runStoreIO storeHandle $ + runWorkflowWith + (defaultWorkflowRunOptions & #snapshotPolicy .~ Every 2) + (WorkflowName "corr-every") + (WorkflowId "c1") + (countingSixSteps counterE) + neverRes `shouldBe` Right (Completed [1, 2, 3, 4, 5, 6]) + everyRes `shouldBe` Right (Completed [1, 2, 3, 4, 5, 6]) + Right neverEvents <- + Store.runStoreIO storeHandle $ + Store.readStreamForward (StreamName "wf:corr-never-c1") (StreamVersion 0) 100 + Right everyEvents <- + Store.runStoreIO storeHandle $ + Store.readStreamForward (StreamName "wf:corr-every-c1") (StreamVersion 0) 100 + let stepResults evs = + [ (k, v) + | Right (StepRecorded k v _) <- decodeRecorded workflowJournalCodec <$> Vector.toList evs + ] + stepResults neverEvents `shouldBe` stepResults everyEvents + -- The snapshot seed equals the map a full version-0 replay would fold. + Right (Just (seedMap, _)) <- + Store.runStoreIO storeHandle $ loadWorkflowSnapshot (StreamName "wf:corr-every-c1") + seedMap `shouldBe` Map.fromList (stepResults everyEvents) + + -- Validation (d): an advisory snapshot whose discriminant no longer matches + -- is ignored and the workflow hydrates via full replay. + it "hydrates via full replay when the snapshot discriminant mismatches" $ \storeHandle -> do + counter <- newIORef (0 :: Int) + let name = WorkflowName "dmiss" + wid = WorkflowId "d1" + opts = defaultWorkflowRunOptions & #snapshotPolicy .~ Every 2 + _ <- Store.runStoreIO storeHandle $ runWorkflowWith opts name wid (countingSixSteps counter) + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + Tx.statement ("wf:dmiss-d1", "stale-shape") corruptSnapshotShapeStmt + Right mSeed <- Store.runStoreIO storeHandle $ loadWorkflowSnapshot (StreamName "wf:dmiss-d1") + mSeed `shouldBe` Nothing + resumed <- Store.runStoreIO storeHandle $ runWorkflowWith opts name wid (countingSixSteps counter) + resumed `shouldBe` Right (Completed [1, 2, 3, 4, 5, 6]) + + -- Validation (d), second arm: corrupt snapshot JSON is treated as a miss. + it "hydrates via full replay when the snapshot JSON is corrupt" $ \storeHandle -> do + (exporter, metricsRef) <- inMemoryMetricExporter + (provider, _env) <- + createMeterProvider + emptyMaterializedResources + defaultSdkMeterProviderOptions{metricExporter = Just exporter} + meter <- getMeter provider Telemetry.keiroInstrumentationLibrary + keiroMetrics <- Telemetry.newKeiroMetrics meter + counter <- newIORef (0 :: Int) + let name = WorkflowName "cjson" + wid = WorkflowId "d2" + opts = + defaultWorkflowRunOptions + & #snapshotPolicy + .~ Every 2 + & #metrics + ?~ keiroMetrics + _ <- Store.runStoreIO storeHandle $ runWorkflowWith opts name wid (countingSixSteps counter) + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + Tx.statement ("wf:cjson-d2", Aeson.String "bad") corruptSnapshotStateStmt + Right mSeed <- Store.runStoreIO storeHandle $ loadWorkflowSnapshot (StreamName "wf:cjson-d2") + mSeed `shouldBe` Nothing + resumed <- Store.runStoreIO storeHandle $ runWorkflowWith opts name wid (countingSixSteps counter) + resumed `shouldBe` Right (Completed [1, 2, 3, 4, 5, 6]) + _ <- forceFlushMeterProvider provider Nothing + exported <- readIORef metricsRef + let scalars = flattenScalarPoints exported + lookup "keiro.snapshot.decode.failures" scalars `shouldBe` Just (IntNumber 1) + lookup "keiro.snapshot.read.misses" scalars `shouldBe` Just (IntNumber 2) + + describe "Keiro.Workflow.Resume" $ around (withFreshStore fixture) $ do + -- M2: crash mid-run, then a resume pass drives the workflow to Completed + -- without re-running the already-journaled step. + it "resumes a crashed mid-run workflow, running only the un-journaled tail" $ \storeHandle -> do + counter <- newIORef (0 :: Int) + let name = WorkflowName "crash-demo" + wid = WorkflowId "cd-1" + -- Simulate a crash after step 1's append has committed. + crashed <- + try + ( Store.runStoreIO storeHandle $ + runWorkflow name wid (crashAfterStep1 counter) + ) :: + IO (Either SomeException (Either Store.StoreError (WorkflowOutcome (Int, Int, Int)))) + case crashed of + Left _ -> pure () -- the SimulatedCrash unwound the run, as intended + Right other -> expectationFailure ("expected a simulated crash, got " <> show other) + readIORef counter >>= \c -> c `shouldBe` 1 + -- Resume with a registry mapping the name to the FULL definition. + let registry = Map.singleton name (WorkflowDef (\_wid -> threeStep counter)) + Right summary <- + Store.runStoreIO storeHandle $ resumeWorkflowsOnce defaultWorkflowResumeOptions registry + summary + `shouldBe` ResumeSummary + { discovered = 1 + , resumed = 1 + , completed = 1 + , stillSuspended = 0 + , unknownName = 0 + , failed = 0 + , transientErrors = 0 + , leaseSkipped = 0 + } + -- Step 1 short-circuited; steps 2 and 3 ran exactly once. + readIORef counter >>= \c -> c `shouldBe` 3 + -- The journal now holds s1, s2, s3, WorkflowCompleted. + Right recorded <- + Store.runStoreIO storeHandle $ + Store.readStreamForward (StreamName "wf:crash-demo-cd-1") (StreamVersion 0) 10 + traverse (decodeRecorded workflowJournalCodec) (Vector.toList recorded) + `shouldSatisfy` \case + Right [StepRecorded "s1" _ _, StepRecorded "s2" _ _, StepRecorded "s3" _ _, WorkflowCompleted _] -> True + _ -> False + -- A second pass discovers nothing — the workflow is finished. + Right summary2 <- + Store.runStoreIO storeHandle $ resumeWorkflowsOnce defaultWorkflowResumeOptions registry + summary2 `shouldBe` emptyResumeSummary + + -- M3: a workflow suspended on an awaited step is driven to Completed once + -- that step is journaled (here simulated; an EP-39/EP-40 wake source would + -- journal the same StepRecorded end to end). + it "resumes a suspended workflow once its awaited step is journaled" $ \storeHandle -> do + counter <- newIORef (0 :: Int) + let name = WorkflowName "await-demo" + wid = WorkflowId "ad-1" + suspended <- + Store.runStoreIO storeHandle $ runWorkflow name wid (awaitingThenStep counter) + suspended `shouldBe` Right Suspended + -- Simulate the wake source resolving the await. + Right () <- Store.runStoreIO storeHandle $ do + now <- liftIO getCurrentTime + appendJournalEntry name wid (StepRecorded "awk:approval" (toJSON ("ok" :: Text)) now) + let registry = Map.singleton name (WorkflowDef (\_wid -> awaitingThenStep counter)) + Right summary <- + Store.runStoreIO storeHandle $ resumeWorkflowsOnce defaultWorkflowResumeOptions registry + summary + `shouldBe` ResumeSummary + { discovered = 1 + , resumed = 1 + , completed = 1 + , stillSuspended = 0 + , unknownName = 0 + , failed = 0 + , transientErrors = 0 + , leaseSkipped = 0 + } + readIORef counter >>= \c -> c `shouldBe` 1 + Right recorded <- + Store.runStoreIO storeHandle $ + Store.readStreamForward (StreamName "wf:await-demo-ad-1") (StreamVersion 0) 10 + traverse (decodeRecorded workflowJournalCodec) (Vector.toList recorded) + `shouldSatisfy` \case + Right [StepRecorded "awk:approval" _ _, StepRecorded "use" _ _, WorkflowCompleted _] -> True + _ -> False + + -- M4: a discovered workflow whose name is absent from the registry is + -- skipped and counted, never silently dropped or fatal. + it "skips and counts a workflow whose name is absent from the registry" $ \storeHandle -> do + counter <- newIORef (0 :: Int) + let name = WorkflowName "orphan" + wid = WorkflowId "or-1" + crashed <- + try + ( Store.runStoreIO storeHandle $ + runWorkflow name wid (crashAfterStep1 counter) + ) :: + IO (Either SomeException (Either Store.StoreError (WorkflowOutcome (Int, Int, Int)))) + case crashed of + Left _ -> pure () + Right other -> expectationFailure ("expected a simulated crash, got " <> show other) + -- Empty registry: the orphan is surfaced via unknownName, not completed. + Right summary <- + Store.runStoreIO storeHandle $ resumeWorkflowsOnce defaultWorkflowResumeOptions Map.empty + summary + `shouldBe` ResumeSummary + { discovered = 1 + , resumed = 0 + , completed = 0 + , stillSuspended = 0 + , unknownName = 1 + , failed = 0 + , transientErrors = 0 + , leaseSkipped = 0 + } + -- The journal is unchanged: still one step, no completion. + Right recorded <- + Store.runStoreIO storeHandle $ + Store.readStreamForward (StreamName "wf:orphan-or-1") (StreamVersion 0) 10 + Vector.length recorded `shouldBe` 1 + + it "isolates a poison workflow so a healthy workflow still completes" $ \storeHandle -> do + healthyCounter <- newIORef (0 :: Int) + let poisonName = WorkflowName "poison" + poisonId = WorkflowId "poison-1" + healthyName = WorkflowName "healthy" + healthyId = WorkflowId "healthy-1" + opts = + defaultWorkflowResumeOptions + & #maxAttempts + .~ 1 + & #logEvent + .~ const (pure ()) + registry = + Map.fromList + [ (poisonName, WorkflowDef (\_ -> liftIO (throwIO SimulatedCrash) *> pure (0 :: Int))) + , (healthyName, WorkflowDef (\_ -> threeStep healthyCounter)) + ] + now <- getCurrentTime + Right () <- + Store.runStoreIO storeHandle $ + appendJournalEntry poisonName poisonId (StepRecorded "seed" (toJSON True) now) + crashed <- + try + ( Store.runStoreIO storeHandle $ + runWorkflow healthyName healthyId (crashAfterStep1 healthyCounter) + ) :: + IO (Either SomeException (Either Store.StoreError (WorkflowOutcome (Int, Int, Int)))) + case crashed of + Left _ -> pure () + Right other -> expectationFailure ("expected a simulated crash, got " <> show other) + Right summary <- Store.runStoreIO storeHandle $ resumeWorkflowsOnce opts registry + summary + `shouldBe` emptyResumeSummary + { discovered = 2 + , resumed = 2 + , completed = 1 + , failed = 1 + } + readIORef healthyCounter >>= \c -> c `shouldBe` 3 + Right (Just poisonRow) <- Store.runStoreIO storeHandle $ Instance.lookupInstance poisonName poisonId + poisonRow ^. #status `shouldBe` Instance.WfFailed + + it "marks a crashing workflow failed and short-circuits later direct runs" $ \storeHandle -> do + let name = WorkflowName "terminal-poison" + wid = WorkflowId "tp-1" + opts = + defaultWorkflowResumeOptions + & #maxAttempts + .~ 1 + & #logEvent + .~ const (pure ()) + registry = Map.singleton name (WorkflowDef (\_ -> liftIO (throwIO SimulatedCrash) *> pure (0 :: Int))) + now <- getCurrentTime + Right () <- + Store.runStoreIO storeHandle $ + appendJournalEntry name wid (StepRecorded "seed" (toJSON True) now) + Right summary <- Store.runStoreIO storeHandle $ resumeWorkflowsOnce opts registry + failed summary `shouldBe` 1 + Right (Just row) <- Store.runStoreIO storeHandle $ Instance.lookupInstance name wid + row ^. #status `shouldBe` Instance.WfFailed + row ^. #attempts `shouldBe` 1 + direct <- Store.runStoreIO storeHandle $ runWorkflow name wid (step (StepName "never") (pure (1 :: Int))) + direct `shouldBe` Right Failed + Right recordedFailed <- + Store.runStoreIO storeHandle $ + Store.readStreamForward (StreamName "wf:terminal-poison-tp-1") (StreamVersion 0) 10 + traverse (decodeRecorded workflowJournalCodec) (Vector.toList recordedFailed) + `shouldSatisfy` \case + Right events -> any (\case WorkflowFailed{} -> True; _ -> False) events + _ -> False + + it "classifies thrown store errors as transient without consuming attempts" $ \storeHandle -> do + let name = WorkflowName "transient" + wid = WorkflowId "tr-1" + opts = defaultWorkflowResumeOptions & #logEvent .~ const (pure ()) + registry = + Map.singleton name $ + WorkflowDef + ( \_ -> do + _ <- throwError (Store.ConnectionLost "boom") + pure (0 :: Int) + ) + now <- getCurrentTime + Right () <- + Store.runStoreIO storeHandle $ + appendJournalEntry name wid (StepRecorded "seed" (toJSON True) now) + Right summary <- Store.runStoreIO storeHandle $ resumeWorkflowsOnce opts registry + transientErrors summary `shouldBe` 1 + failed summary `shouldBe` 0 + Right (Just row) <- Store.runStoreIO storeHandle $ Instance.lookupInstance name wid + row ^. #attempts `shouldBe` 0 + row ^. #status `shouldBe` Instance.WfRunning + + it "keeps the fixed-poll loop alive when one pass contains a poison workflow" $ \storeHandle -> do + done <- newEmptyMVar + healthyCounter <- newIORef (0 :: Int) + let poisonName = WorkflowName "fixed-loop-poison" + poisonId = WorkflowId "flp-1" + healthyName = WorkflowName "fixed-loop-healthy" + healthyId = WorkflowId "flh-1" + opts = + defaultWorkflowResumeOptions + & #pollInterval + .~ 50_000 + & #maxAttempts + .~ 1 + & #logEvent + .~ const (pure ()) + healthyBody = threeStepThenSignal healthyCounter done + registry = + Map.fromList + [ (poisonName, WorkflowDef (\_ -> liftIO (throwIO SimulatedCrash) *> pure (0 :: Int))) + , (healthyName, WorkflowDef (\_ -> healthyBody)) + ] + now <- getCurrentTime + Right () <- + Store.runStoreIO storeHandle $ + appendJournalEntry poisonName poisonId (StepRecorded "seed" (toJSON True) now) + crashed <- + try + ( Store.runStoreIO storeHandle $ + runWorkflow healthyName healthyId (crashAfterStep1 healthyCounter) + ) :: + IO (Either SomeException (Either Store.StoreError (WorkflowOutcome (Int, Int, Int)))) + case crashed of + Left _ -> pure () + Right other -> expectationFailure ("expected a simulated crash, got " <> show other) + worker <- forkIO (void (Store.runStoreIO storeHandle (runWorkflowResumeWorkerWith opts registry))) + completed <- timeout 5_000_000 (takeMVar done) + status <- threadStatus worker + killThread worker + completed `shouldBe` Just () + status `shouldSatisfy` \case + ThreadFinished -> False + ThreadDied -> False + _ -> True + + it "claims one workflow instance for a single live owner and releases it" $ \storeHandle -> do + let name = WorkflowName "lease-claim" + wid = WorkflowId "lc-1" + Right claimedA <- Store.runStoreIO storeHandle $ Instance.claimInstance "owner-a" 30 name wid + claimedA `shouldBe` True + Right claimedB <- Store.runStoreIO storeHandle $ Instance.claimInstance "owner-b" 30 name wid + claimedB `shouldBe` False + Right () <- Store.runStoreIO storeHandle $ Instance.releaseInstance "owner-a" False name wid + Right claimedBAfterRelease <- Store.runStoreIO storeHandle $ Instance.claimInstance "owner-b" 30 name wid + claimedBAfterRelease `shouldBe` True + + it "lets an expired workflow lease be taken and resets attempts on progressed release" $ \storeHandle -> do + let name = WorkflowName "lease-expire" + wid = WorkflowId "le-1" + Right claimedA <- Store.runStoreIO storeHandle $ Instance.claimInstance "owner-a" 30 name wid + claimedA `shouldBe` True + Right attempt <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + Instance.recordCrashTx "le-1" "lease-expire" "boom" + attempt `shouldBe` 1 + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + Tx.sql "UPDATE keiro.keiro_workflows SET lease_expires_at = now() - interval '1 second', next_attempt_at = now() - interval '1 second' WHERE workflow_id = 'le-1' AND workflow_name = 'lease-expire'" + Right claimedB <- Store.runStoreIO storeHandle $ Instance.claimInstance "owner-b" 30 name wid + claimedB `shouldBe` True + Right () <- Store.runStoreIO storeHandle $ Instance.releaseInstance "owner-b" True name wid + Right (Just row) <- Store.runStoreIO storeHandle $ Instance.lookupInstance name wid + row ^. #attempts `shouldBe` 0 + row ^. #lastError `shouldBe` Nothing + row ^. #nextAttemptAt `shouldBe` Nothing + row ^. #leasedBy `shouldBe` Nothing + + it "skips a resume candidate held by another live lease owner" $ \storeHandle -> do + ran <- newIORef False + let name = WorkflowName "lease-skip" + wid = WorkflowId "ls-1" + registry = + Map.singleton name $ + WorkflowDef + ( \_ -> do + liftIO (writeIORef ran True) + pure (0 :: Int) + ) + now <- getCurrentTime + Right () <- + Store.runStoreIO storeHandle $ + appendJournalEntry name wid (StepRecorded "seed" (toJSON True) now) + Right foreignClaim <- Store.runStoreIO storeHandle $ Instance.claimInstance "foreign-owner" 30 name wid + foreignClaim `shouldBe` True + Right summary <- Store.runStoreIO storeHandle $ resumeWorkflowsOnce defaultWorkflowResumeOptions registry + summary + `shouldBe` emptyResumeSummary + { discovered = 1 + , leaseSkipped = 1 + } + readIORef ran `shouldReturn` False + + -- M4: resume on an already-completed workflow is a genuine no-op. + it "discovers nothing for an already-completed workflow and is stable" $ \storeHandle -> do + counter <- newIORef (0 :: Int) + let name = WorkflowName "done-demo" + wid = WorkflowId "dd-1" + done <- Store.runStoreIO storeHandle $ runWorkflow name wid (threeStep counter) + done `shouldBe` Right (Completed (1, 2, 3)) + readIORef counter >>= \c -> c `shouldBe` 3 + let registry = Map.singleton name (WorkflowDef (\_wid -> threeStep counter)) + Right summary1 <- + Store.runStoreIO storeHandle $ resumeWorkflowsOnce defaultWorkflowResumeOptions registry + summary1 `shouldBe` emptyResumeSummary + Right summary2 <- + Store.runStoreIO storeHandle $ resumeWorkflowsOnce defaultWorkflowResumeOptions registry + summary2 `shouldBe` emptyResumeSummary + readIORef counter >>= \c -> c `shouldBe` 3 + + describe "Keiro.Workflow continue-as-new" $ around (withFreshStore fixture) $ do + -- EP-48 headline proof (Checks 1 & 2): a 300-step rolling-total workflow that + -- rotates every 50 steps keeps each physical generation journal bounded by + -- K = rotateEvery + 2 (at most rotateEvery work steps + the one seed step that + -- opened the generation + the one terminal marker), yet returns the correct + -- final total. A single non-rotating run would put all 300 steps on one + -- journal and the per-generation `<= K` bound would fail. + it "rotates a long workflow, bounds each generation, and returns the correct total" $ \storeHandle -> do + counter <- newIORef (0 :: Int) + let name = WorkflowName "roller" + wid = WorkflowId "r-1" + rotateEvery = 50 :: Int + total = 300 :: Int + k = rotateEvery + 2 + body = rollingTotal counter rotateEvery total + -- Re-invoke runWorkflow until it Completes; each call resolves and + -- advances the current generation, exactly as the resume worker does. + drive :: Int -> IO Int + drive budget + | budget <= 0 = + expectationFailure "workflow did not complete within the rotation budget" >> pure (-1) + | otherwise = do + outcome <- Store.runStoreIO storeHandle (runWorkflow name wid body) + case outcome of + Right ContinuedAsNew -> drive (budget - 1) + Right (Completed t) -> pure t + other -> expectationFailure ("unexpected outcome: " <> show other) >> pure (-1) + -- The first invocation rotates (generation 0 did rotateEvery steps). + firstOutcome <- Store.runStoreIO storeHandle (runWorkflow name wid body) + firstOutcome `shouldBe` Right ContinuedAsNew + -- Drive the remaining generations to completion (bounded passes). + finalTotal <- drive (total `div` rotateEvery + 3) + -- Check 2: correct result, and each side effect ran exactly once. + finalTotal `shouldBe` total + readIORef counter >>= (`shouldBe` total) + -- The workflow rotated to its final generation (300/50 = 6 generations: 0..5). + Right gen <- Store.runStoreIO storeHandle (currentGeneration name wid) + gen `shouldBe` (total `div` rotateEvery - 1) + -- Check 1: every generation's physical journal is bounded by K, and the + -- total is split ACROSS generations (bounded per generation, not in + -- aggregate). Each generation holds exactly 1 seed + rotateEvery work + 1 + -- marker = K events, so the sum is total + 2 per generation. + lengths <- + traverse + ( \g -> do + let streamName = workflowGenerationStreamName name wid g + Right evs <- Store.runStoreIO storeHandle (Store.readStreamForward streamName (StreamVersion 0) 1000) + pure (Vector.length evs) + ) + [0 .. gen] + for_ lengths (`shouldSatisfy` (<= k)) + sum lengths `shouldBe` (total + 2 * (gen + 1)) + -- The first generation ends with a rotation marker; the last with a + -- completion marker. + Right gen0evs <- Store.runStoreIO storeHandle (Store.readStreamForward (workflowGenerationStreamName name wid 0) (StreamVersion 0) 1000) + (decodeRecorded workflowJournalCodec <$> Vector.toList gen0evs) + `shouldSatisfy` any + ( \case + Right (WorkflowContinuedAsNew 1 _) -> True + _ -> False + ) + Right lastEvs <- Store.runStoreIO storeHandle (Store.readStreamForward (workflowGenerationStreamName name wid gen) (StreamVersion 0) 1000) + (decodeRecorded workflowJournalCodec <$> Vector.toList lastEvs) + `shouldSatisfy` any + ( \case + Right (WorkflowCompleted _) -> True + _ -> False + ) + + -- EP-48 Check 3: discovery and resume follow the CURRENT generation. After a + -- rotation the rotated (newer) generation is unfinished and discoverable — + -- the older generation's WorkflowContinuedAsNew marker does NOT mask it — and + -- the resume worker drives the rotated generation forward to completion. + it "rediscovers and resumes a rotated workflow on its current generation" $ \storeHandle -> do + counter <- newIORef (0 :: Int) + let name = WorkflowName "roller2" + wid = WorkflowId "r-2" + rotateEvery = 50 :: Int + total = 150 :: Int + registry = Map.singleton name (WorkflowDef (\_ -> rollingTotal counter rotateEvery total)) + resumeUntilDone :: Int -> IO () + resumeUntilDone budget + | budget <= 0 = expectationFailure "resume did not complete the rotated workflow" + | otherwise = do + Right summary <- + Store.runStoreIO storeHandle (resumeWorkflowsOnce defaultWorkflowResumeOptions registry) + if completed summary == 1 then pure () else resumeUntilDone (budget - 1) + -- First run rotates onto generation 1. + firstOutcome <- Store.runStoreIO storeHandle (runWorkflow name wid (rollingTotal counter rotateEvery total)) + firstOutcome `shouldBe` Right ContinuedAsNew + -- The rotated current generation (1) is unfinished and discoverable. + now <- getCurrentTime + Right unfinished <- Store.runStoreIO storeHandle (findUnfinishedWorkflowIds now) + unfinished `shouldBe` [("r-2", "roller2")] + -- The resume worker drives the rotated generation(s) to completion. + resumeUntilDone (total `div` rotateEvery + 3) + readIORef counter >>= (`shouldBe` total) + -- Finished: discovery now reports nothing for it. + finalNow <- getCurrentTime + Right finalUnfinished <- Store.runStoreIO storeHandle (findUnfinishedWorkflowIds finalNow) + finalUnfinished `shouldBe` [] + + describe "Keiro.Workflow patch API" $ around (withFreshStore fixture) $ do + it "an in-flight instance observes the OLD branch; a fresh instance the NEW branch; the decision is journaled once and stable" $ \storeHandle -> do + counter <- newIORef (0 :: Int) + let name = WorkflowName "patchwf" + inflight = WorkflowId "inflight-1" + fresh = WorkflowId "fresh-1" + patchOptions = defaultWorkflowRunOptions & #activePatches .~ Set.singleton fraudPatchId + + -- 1. Run the in-flight instance to a suspension under the PRE-patch code. + pre <- Store.runStoreIO storeHandle $ runWorkflow name inflight (prePatchWorkflow counter) + pre `shouldBe` Right Suspended + + -- 2. Redeploy: re-run the SAME instance id under the POST-patch code. It + -- already journaled reserve-inventory, so it is in flight -> False. + r1 <- Store.runStoreIO storeHandle $ runWorkflowWith patchOptions name inflight (postPatchWorkflow counter) + r1 `shouldBe` Right (Completed "old-branch") + + -- 3. Replay the in-flight instance again: same OLD branch, every time. + r2 <- Store.runStoreIO storeHandle $ runWorkflowWith patchOptions name inflight (postPatchWorkflow counter) + r2 `shouldBe` Right (Completed "old-branch") + + -- 4. A fresh instance under the POST-patch code takes the NEW branch. + f1 <- Store.runStoreIO storeHandle $ runWorkflowWith patchOptions name fresh (postPatchWorkflow counter) + f1 `shouldBe` Right (Completed "new-branch") + -- and stays on the new branch on replay. + f2 <- Store.runStoreIO storeHandle $ runWorkflowWith patchOptions name fresh (postPatchWorkflow counter) + f2 `shouldBe` Right (Completed "new-branch") + + -- 5. The patch decision is journaled exactly once per instance, with the + -- expected Bool, on the patch: key. + Right inflightJournal <- + Store.runStoreIO storeHandle $ + Store.readStreamForward (StreamName "wf:patchwf-inflight-1") (StreamVersion 0) 20 + let inflightDecisions = + [ v + | Right ev <- map (decodeRecorded workflowJournalCodec) (Vector.toList inflightJournal) + , StepRecorded k v _ <- [ev] + , k == patchStepName fraudPatchId + ] + inflightDecisions `shouldBe` [toJSON False] + + Right freshJournal <- + Store.runStoreIO storeHandle $ + Store.readStreamForward (StreamName "wf:patchwf-fresh-1") (StreamVersion 0) 20 + let freshDecisions = + [ v + | Right ev <- map (decodeRecorded workflowJournalCodec) (Vector.toList freshJournal) + , StepRecorded k v _ <- [ev] + , k == patchStepName fraudPatchId + ] + freshDecisions `shouldBe` [toJSON True] + let freshPatchSets = + [ v + | Right ev <- map (decodeRecorded workflowJournalCodec) (Vector.toList freshJournal) + , StepRecorded k v _ <- [ev] + , k == patchSetStepName + ] + freshPatchSets `shouldBe` [toJSON [unPatchId fraudPatchId]] + + it "a fresh instance suspended before its patch call still takes the NEW branch" $ \storeHandle -> do + counter <- newIORef (0 :: Int) + let name = WorkflowName "patch-after-suspend" + wid = WorkflowId "pas-1" + patchOptions = defaultWorkflowRunOptions & #activePatches .~ Set.singleton fraudPatchId + Right Suspended <- + Store.runStoreIO storeHandle $ + runWorkflowWith patchOptions name wid (postPatchAfterSuspendWorkflow counter) + now <- getCurrentTime + Right () <- + Store.runStoreIO storeHandle $ + appendJournalEntry name wid (StepRecorded "awk:gate" Aeson.Null now) + resumed <- + Store.runStoreIO storeHandle $ + runWorkflowWith patchOptions name wid (postPatchAfterSuspendWorkflow counter) + resumed `shouldBe` Right (Completed "new-branch") + + it "an in-flight instance with only wake-source completions stays on the OLD branch" $ \storeHandle -> do + let name = WorkflowName "patch-wake-only" + wid = WorkflowId "pwo-1" + patchOptions = defaultWorkflowRunOptions & #activePatches .~ Set.singleton fraudPatchId + Right Suspended <- Store.runStoreIO storeHandle $ runWorkflow name wid prePatchWakeOnlyWorkflow + now <- getCurrentTime + Right () <- + Store.runStoreIO storeHandle $ + appendJournalEntry name wid (StepRecorded "awk:gate" Aeson.Null now) + resumed <- + Store.runStoreIO storeHandle $ + runWorkflowWith patchOptions name wid postPatchWakeOnlyWorkflow + resumed `shouldBe` Right (Completed "old-branch") + + it "records the active patch set again for a fresh rotated generation" $ \storeHandle -> do + let name = WorkflowName "patch-rotating" + wid = WorkflowId "pr-1" + patchOptions = defaultWorkflowRunOptions & #activePatches .~ Set.singleton fraudPatchId + first <- Store.runStoreIO storeHandle $ runWorkflowWith patchOptions name wid rotatingPatchWorkflow + first `shouldBe` Right ContinuedAsNew + second <- Store.runStoreIO storeHandle $ runWorkflowWith patchOptions name wid rotatingPatchWorkflow + second `shouldBe` Right (Completed "new-branch") + Right gen1Journal <- + Store.runStoreIO storeHandle $ + Store.readStreamForward (workflowGenerationStreamName name wid 1) (StreamVersion 0) 20 + let gen1PatchSets = + [ v + | Right ev <- map (decodeRecorded workflowJournalCodec) (Vector.toList gen1Journal) + , StepRecorded k v _ <- [ev] + , k == patchSetStepName + ] + gen1PatchSets `shouldBe` [toJSON [unPatchId fraudPatchId]] + + describe "Keiro.Wake" $ around (withFreshStore fixture) $ do + -- EP-50: the wake primitive over kiroku's existing per-store notifier. + it "returns WokenByTimeout when idle (no append)" $ \store -> do + wake <- wakeSignalFromStore store + reason <- waitForWake wake 200000 -- 200 ms + reason `shouldBe` WokenByTimeout + + it "returns WokenByNotify promptly after a real append" $ \store -> do + wake <- wakeSignalFromStore store + -- A real append bumps the streams row and fires kiroku's NOTIFY on + -- kiroku.events; the store's notifier ticks the broadcast channel. + now <- getCurrentTime + Right () <- + Store.runStoreIO store $ + appendJournalEntry (WorkflowName "wakedemo") (WorkflowId "w1") (StepRecorded "s" (toJSON True) now) + reason <- waitForWake wake 5000000 -- generous 5 s ceiling; the round-trip is milliseconds + reason `shouldBe` WokenByNotify + + it "neverWake always returns WokenByTimeout" $ \_store -> do + reason <- waitForWake neverWake 100000 + reason `shouldBe` WokenByTimeout + + describe "Keiro.Workflow push latency (EP-50)" $ around (withFreshStore fixture) $ do + -- The user-visible win: a gated workflow resumes within sub-second of the + -- gate append, under a deliberately large (10 s) fallback — so a pass that + -- resumes it sub-second can only have been woken by the NOTIFY, not the poll. + it "resumes a gated workflow sub-second after the gate append (10s fallback)" $ \store -> do + done <- newEmptyMVar + let name = WorkflowName "pushwf" + wid = WorkflowId "p-1" + registry = Map.singleton name (WorkflowDef (\_ -> gateThenSignal done)) + opts = defaultWorkflowResumeOptions & #pollInterval .~ 10000000 -- 10 s fallback + first <- Store.runStoreIO store (runWorkflow name wid (gateThenSignal done)) + first `shouldBe` Right Suspended + worker <- forkIO (runWorkflowResumeWorkerPush store opts registry) + -- Let the worker start, duplicate the tick channel, and park in its wait + -- before we append, so the gate's NOTIFY cannot be missed. + threadDelay 250000 + now <- getCurrentTime + Right () <- + Store.runStoreIO store $ + appendJournalEntry name wid (StepRecorded "awk:gate" (toJSON ()) now) + resumed <- timeout 5000000 (takeMVar done) + t1 <- getCurrentTime + killThread worker + resumed `shouldBe` Just () + let latency = realToFrac (diffUTCTime t1 now) :: Double + latency `shouldSatisfy` (< 1.0) + + it "logs a failed push pass and keeps draining after the store recovers" $ \store -> do + done <- newEmptyMVar + logs <- newIORef [] + let name = WorkflowName "push-recover" + wid = WorkflowId "pr-1" + registry = Map.singleton name (WorkflowDef (\_ -> gateThenSignal done)) + opts = + defaultWorkflowResumeOptions + & #pollInterval + .~ 100_000 + & #logEvent + .~ \event -> modifyIORef' logs (<> [event]) + waitForPassFailure = timeout 5_000_000 $ do + let go = do + seen <- readIORef logs + if any isPassFailure seen + then pure () + else threadDelay 20_000 >> go + go + isPassFailure = \case + ResumePassFailed{} -> True + _ -> False + first <- Store.runStoreIO store (runWorkflow name wid (gateThenSignal done)) + first `shouldBe` Right Suspended + Right () <- + Store.runStoreIO store $ + Store.runTransaction $ + Tx.sql "ALTER TABLE keiro.keiro_workflow_steps RENAME TO keiro_workflow_steps_hidden" + worker <- forkIO (runWorkflowResumeWorkerPush store opts registry) + logged <- waitForPassFailure + logged `shouldBe` Just () + Right () <- + Store.runStoreIO store $ + Store.runTransaction $ + Tx.sql "ALTER TABLE keiro.keiro_workflow_steps_hidden RENAME TO keiro_workflow_steps" + now <- getCurrentTime + Right () <- + Store.runStoreIO store $ + appendJournalEntry name wid (StepRecorded "awk:gate" (toJSON ()) now) + resumed <- timeout 5_000_000 (takeMVar done) + status <- threadStatus worker + killThread worker + resumed `shouldBe` Just () + status `shouldSatisfy` \case + ThreadFinished -> False + ThreadDied -> False + _ -> True + + describe "Keiro.Workflow push fallback (EP-50)" $ around (withFreshStore fixture) $ do + -- Push is strictly an optimization: with the worker on 'neverWake' (every + -- NOTIFY dropped) and a small fallback, the gated workflow still drains on + -- the durable poll. + it "still drains on the fallback timeout when no notification is delivered" $ \store -> do + done <- newEmptyMVar + let name = WorkflowName "fallbackwf" + wid = WorkflowId "f-1" + registry = Map.singleton name (WorkflowDef (\_ -> gateThenSignal done)) + onePass = void (Store.runStoreIO store (resumeWorkflowsOnce defaultWorkflowResumeOptions registry)) + first <- Store.runStoreIO store (runWorkflow name wid (gateThenSignal done)) + first `shouldBe` Right Suspended + worker <- forkIO (runPollLoopWith neverWake 200000 onePass) -- 200 ms fallback, no notifications + now <- getCurrentTime + Right () <- + Store.runStoreIO store $ + appendJournalEntry name wid (StepRecorded "awk:gate" (toJSON ()) now) + resumed <- timeout 5000000 (takeMVar done) + killThread worker + resumed `shouldBe` Just () + + describe "Shard lease" $ around (withFreshStore fixture) $ do + -- EP-51 M2: claim / renew / release / expiry at the SQL layer, with explicit + -- `now` timestamps standing in for the passage of time (no workers yet). The + -- exclusion guarantee is the FOR UPDATE SKIP LOCKED claim; disjointness and + -- failover are both observable purely from the lease table. + let subName = SubscriptionName "orders-shard" + wA = WorkerId sampleUuid + wB = WorkerId sampleUuid2 + ttl = 30 :: NominalDiffTime + t0 = UTCTime (ModifiedJulianDay 60000) (secondsToDiffTime 0) + tExpired = addUTCTime 60 t0 -- past A's 30 s lease + shardOpts = defaultShardedWorkerOptions (Category (CategoryName "orders")) 4 + it "validates sharded worker options before startup" $ \_store -> do + shouldBeRight_ (mkShardedWorkerOptions shardOpts) + mkShardedWorkerOptions (shardOpts & #shardCount .~ 0) + `shouldBeLeft` InvalidShardCount 0 + mkShardedWorkerOptions (shardOpts & #leaseTtl .~ 0) + `shouldBeLeft` InvalidShardLeaseTtl 0 + mkShardedWorkerOptions (shardOpts & #renewInterval .~ 0) + `shouldBeLeft` InvalidShardRenewInterval 0 + mkShardedWorkerOptions (shardOpts & #leaseTtl .~ 10 & #renewInterval .~ 10) + `shouldBeLeft` InvalidShardLeaseRenewInterval 10 10 + mkShardedWorkerOptions (shardOpts & #batchSize .~ 0) + `shouldBeLeft` InvalidShardBatchSize 0 + mkShardedWorkerOptions (shardOpts & #bufferSize .~ 0) + `shouldBeLeft` InvalidShardBufferSize 0 + mkShardedWorkerOptions (shardOpts & #handlerRetryDelay .~ KirokuSub.RetryDelay (-1)) + `shouldBeLeft` InvalidShardHandlerRetryDelay (KirokuSub.RetryDelay (-1)) + mkShardedWorkerOptions (shardOpts & #retryPolicy .~ KirokuSub.RetryPolicy 0) + `shouldBeLeft` InvalidShardRetryMaxAttempts 0 + + it "ensureShardRows populates N rows once (idempotent on re-run)" $ \store -> do + Right () <- Store.runStoreIO store $ Store.runTransaction $ do + ensureShardRows subName 4 + ensureShardRows subName 4 + Right rows <- Store.runStoreIO store $ Store.runTransaction (listShardOwnership subName) + map (\(b, _, _) -> b) rows `shouldBe` [0, 1, 2, 3] + all (\(_, o, _) -> isNothing o) rows `shouldBe` True + + it "worker A claims all N when free; B claims 0 while A holds valid leases" $ \store -> do + Right claimedA <- Store.runStoreIO store $ Store.runTransaction $ do + ensureShardRows subName 4 + claimShardsTx subName wA 4 t0 ttl + claimedA `shouldBe` [0, 1, 2, 3] + Right claimedB <- Store.runStoreIO store $ Store.runTransaction (claimShardsTx subName wB 4 t0 ttl) + claimedB `shouldBe` [] + + it "B claims A's buckets after A's lease expires; A then renews nothing" $ \store -> do + Right _ <- Store.runStoreIO store $ Store.runTransaction $ do + ensureShardRows subName 4 + claimShardsTx subName wA 4 t0 ttl + Right claimedB <- Store.runStoreIO store $ Store.runTransaction (claimShardsTx subName wB 4 tExpired ttl) + claimedB `shouldBe` [0, 1, 2, 3] + -- A lost every bucket to B, so its renew returns the empty set: this is how + -- a worker learns it no longer owns a bucket and stops reading it. + Right heldA <- Store.runStoreIO store $ Store.runTransaction (renewLeaseTx subName wA tExpired ttl) + heldA `shouldBe` [] + + it "renewLease returns only still-held buckets" $ \store -> do + Right held <- Store.runStoreIO store $ Store.runTransaction $ do + ensureShardRows subName 4 + _ <- claimShardsTx subName wA 4 t0 ttl + renewLeaseTx subName wA t0 ttl + held `shouldBe` [0, 1, 2, 3] + + it "releaseShards: relinquished buckets are immediately claimable" $ \store -> do + Right _ <- Store.runStoreIO store $ Store.runTransaction $ do + ensureShardRows subName 4 + _ <- claimShardsTx subName wA 4 t0 ttl + releaseShardsTx subName wA [0, 1] + -- Even while A's lease over 2,3 is still valid, the released 0,1 are claimable. + Right claimedB <- Store.runStoreIO store $ Store.runTransaction (claimShardsTx subName wB 4 t0 ttl) + claimedB `shouldBe` [0, 1] + + it "fairShareTarget divides buckets evenly (ceil)" $ \_store -> do + fairShareTarget 6 3 `shouldBe` 2 + fairShareTarget 6 4 `shouldBe` 2 + fairShareTarget 7 3 `shouldBe` 3 + fairShareTarget 4 0 `shouldBe` 4 -- a non-positive estimate claims everything + it "acquireOutcome keeps previous ownership on acquire failure" $ \_store -> do + let previous = Set.fromList [0, 2] + acquireOutcome previous (Left "database unavailable") + `shouldBe` (previous, Just (ShardAcquireFailed "database unavailable")) + acquireOutcome previous (Right (Set.fromList [1, 3])) + `shouldBe` (Set.fromList [1, 3], Nothing) + + it "ensureShards rejects a shardCount mismatch" $ \store -> do + let lease4 = + ShardLease + { subscriptionName = subName + , workerId = wA + , shardCount = 4 + , leaseTtl = ttl + } + lease6 = + ShardLease + { subscriptionName = subName + , workerId = wA + , shardCount = 6 + , leaseTtl = ttl + } + Right () <- Store.runStoreIO store (ensureShards lease4) + Store.runStoreIO store (ensureShards lease6) + `shouldThrow` \case + ShardCountMismatch name configured found -> + name == "orders-shard" && configured == 6 && found == [4] + + describe "Sharded subscription single worker" $ around (withFreshStore fixture) $ do + -- EP-51 M3: one process owning all N buckets drains a seeded category exactly + -- once. The sink is idempotent on event_id, so "count == total" proves every + -- event was delivered with none missing and none surviving as a duplicate row. + it "one worker with N=4 buckets drains a seeded category exactly once" $ \store -> do + Right () <- Store.runStoreIO store $ Store.runTransaction (Tx.sql createShardSinkSql) + total <- seedOrders store 8 5 -- 40 events across 8 streams + let opts = + (defaultShardedWorkerOptions (Category (CategoryName "orders")) 4) + { leaseTtl = 3 + , renewInterval = 0.3 + } + w <- forkIO (runShardedSubscriptionGroup store (SubscriptionName "orders-sub") opts (sinkHandler store 1)) + drained <- waitUntilSinkCount store total 20_000_000 + killThread w + drained `shouldBe` True + count <- shardSinkCount store + count `shouldBe` total + maxW <- maxWorkersPerStream store + maxW `shouldBe` 1 + + describe "Sharded subscription drain and failover" $ around (withFreshStore fixture) $ do + -- EP-51 M5: the behavioural acceptance. Three worker processes cooperatively + -- partition a category; we let ownership converge on the *empty* category + -- first (so the churn of cold-start rebalancing touches no events), then seed + -- and drain under stable membership — so each stream is owned by exactly one + -- worker throughout the drain. Then we kill a worker and prove its buckets are + -- re-homed and the new events drain (failover via lease expiry). + let sub = SubscriptionName "orders-failover" + mkOpts = (defaultShardedWorkerOptions (Category (CategoryName "orders")) 6){leaseTtl = 3, renewInterval = 0.3} + it "three workers drain disjointly, then re-home a killed worker's buckets" $ \store -> do + Right () <- Store.runStoreIO store $ Store.runTransaction (Tx.sql createShardSinkSql) + w1 <- forkIO (runShardedSubscriptionGroup store sub mkOpts (sinkHandler store 1)) + w2 <- forkIO (runShardedSubscriptionGroup store sub mkOpts (sinkHandler store 2)) + w3 <- forkIO (runShardedSubscriptionGroup store sub mkOpts (sinkHandler store 3)) + -- Wait for cooperative balance on the empty category: all 6 buckets owned, + -- spread across >= 2 workers, none holding more than its fair share. + balanced <- waitShardsBalanced store sub 6 2 15_000_000 + balanced `shouldBe` True + -- Now seed and drain under stable membership. + total1 <- seedOrders store 12 5 -- 60 events + ok1 <- waitUntilSinkCount store total1 25_000_000 + ok1 `shouldBe` True + -- Disjoint: no stream key was processed by two workers (stable membership, + -- so no re-homing split any stream). + maxW <- maxWorkersPerStream store + maxW `shouldBe` 1 + -- The work genuinely spread (not a monopoly): at least two workers participated. + spread <- distinctWorkers store + spread `shouldSatisfy` (>= 2) + -- Counts sum to total with no duplicate event id (PK on event_id + count). + c1 <- shardSinkCount store + c1 `shouldBe` total1 + -- Kill worker 1 (its readers stop; it stops renewing, so its leases expire). + killThread w1 + -- Seed more across all streams; some hash to worker 1's now-orphaned buckets. + total2 <- seedOrders store 12 5 -- another 60 + -- Failover: a surviving worker re-claims the expired buckets and drains the + -- new events. If re-homing did not happen, events on worker 1's buckets would + -- never drain and this would time out. + ok2 <- waitUntilSinkCount store (total1 + total2) 30_000_000 + killThread w2 + killThread w3 + ok2 `shouldBe` True + c2 <- shardSinkCount store + c2 `shouldBe` (total1 + total2) + + it "a killed worker relinquishes its leases immediately" $ \store -> do + let subImmediate = SubscriptionName "orders-immediate-release" + longTtlOpts = + (defaultShardedWorkerOptions (Category (CategoryName "orders")) 4) + { leaseTtl = 30 + , renewInterval = 0.2 + } + w <- forkIO (runShardedSubscriptionGroup store subImmediate longTtlOpts (sinkHandler store 1)) + owned <- waitShardsBalanced store subImmediate 4 1 10_000_000 + owned `shouldBe` True + killThread w + released <- waitShardsUnowned store subImmediate 4 3_000_000 + released `shouldBe` True + + it "a handler exception is retried in place and drains" $ \store -> do + Right () <- Store.runStoreIO store $ Store.runTransaction (Tx.sql createShardSinkSql) + thrown <- newIORef False + errors <- newIORef [] + let subRestart = SubscriptionName "orders-reader-restart" + opts = + (defaultShardedWorkerOptions (Category (CategoryName "orders")) 2) + { leaseTtl = 3 + , renewInterval = 0.2 + , handlerRetryDelay = KirokuSub.RetryDelay 0.05 + , onShardError = Just (\err -> modifyIORef' errors (err :)) + } + handler ev = do + firstTime <- + atomicModifyIORef' + thrown + ( \seen -> + if seen + then (seen, False) + else (True, True) + ) + when firstTime (throwIO (userError "reader boom")) + sinkHandler store 1 ev + w <- forkIO (runShardedSubscriptionGroup store subRestart opts handler) + balanced <- waitShardsBalanced store subRestart 2 1 10_000_000 + balanced `shouldBe` True + total <- seedOrders store 4 2 + drained <- waitUntilSinkCount store total 20_000_000 + killThread w + drained `shouldBe` True + seenErrors <- readIORef errors + seenErrors `shouldSatisfy` all (\case ShardReaderDied _ _ -> False; _ -> True) + + describe "Sharded subscription ack coupling" $ around (withFreshStore fixture) $ do + it "redelivers a batch-tail event whose handler was killed mid-flight" $ \store -> do + Right () <- Store.runStoreIO store $ Store.runTransaction (Tx.sql createShardSinkSql) + total <- seedOrders store 1 5 + enteredTail <- newEmptyMVar + holdTail <- newEmptyMVar + let sub = SubscriptionName "orders-ack-tail" + opts = + (defaultShardedWorkerOptions (Category (CategoryName "orders")) 1) + { leaseTtl = 3 + , renewInterval = 0.3 + } + blockingHandler ev = do + let orderNumber = parseEither (withObject "OrderPlaced" (.: "n")) (ev ^. #payload) + when (orderNumber == Right (4 :: Int)) $ do + putMVar enteredTail () + takeMVar holdTail + sinkHandler store 1 ev + first <- forkIO (runShardedSubscriptionGroup store sub opts blockingHandler) + entered <- timeout 10_000_000 (takeMVar enteredTail) + entered `shouldBe` Just () + -- The old pull bridge replies Continue before invoking the handler; + -- leave enough time for its batch-tail checkpoint to commit while the + -- handler remains blocked. The ack-coupled bridge introduced by EP-96 + -- remains blocked on the unfilled reply instead. + threadDelay 200_000 + killThread first + second <- forkIO (runShardedSubscriptionGroup store sub opts (sinkHandler store 2)) + drained <- waitUntilSinkCount store total 20_000_000 + killThread second + drained `shouldBe` True + shardSinkCount store `shouldReturn` total + + it "loses no events when a bucket is shed mid-drain during rebalance" $ \store -> do + Right () <- Store.runStoreIO store $ Store.runTransaction (Tx.sql createShardSinkSql) + total <- seedOrders store 24 5 + let sub = SubscriptionName "orders-ack-rebalance" + opts = + (defaultShardedWorkerOptions (Category (CategoryName "orders")) 4) + { leaseTtl = 3 + , renewInterval = 0.3 + , batchSize = 1 + } + slowHandler tag ev = do + threadDelay 100_000 + sinkHandler store tag ev + first <- forkIO (runShardedSubscriptionGroup store sub opts (slowHandler 1)) + -- acquireOwnedBuckets claims one bucket per pass. Starting the joiner + -- while A owns three leaves one claimable bucket for B, making B visible; + -- A's next pass then sheds its excess third bucket while its handler is + -- deliberately slow and in flight. + ownsThree <- waitUntilOwnedShardCount store sub 3 10_000_000 + ownsThree `shouldBe` True + second <- forkIO (runShardedSubscriptionGroup store sub opts (slowHandler 2)) + drained <- waitUntilSinkCount store total 30_000_000 + killThread first + killThread second + drained `shouldBe` True + shardSinkCount store `shouldReturn` total + + it "allows zombie overlap duplicates without losing an event" $ \store -> do + Right () <- Store.runStoreIO store $ Store.runTransaction (Tx.sql createShardSinkSql) + total <- seedOrders store 1 5 + entered <- newEmptyMVar + release <- newEmptyMVar + deliveries <- newIORef ([] :: [EventId]) + successor <- newIORef Nothing + readersA <- newIORef Map.empty + let sub = SubscriptionName "orders-ack-zombie" + opts = + (defaultShardedWorkerOptions (Category (CategoryName "orders")) 1) + { leaseTtl = 2 + , renewInterval = 0.2 + } + leaseA = + ShardLease + { subscriptionName = sub + , workerId = WorkerId sampleUuid + , shardCount = 1 + , leaseTtl = 2 + } + handlerA delivery = do + let ev = delivery ^. #event + modifyIORef' deliveries ((ev ^. #eventId) :) + putMVar entered () + takeMVar release + sinkHandler store 1 ev + pure ShardAckOk + handlerB delivery = do + let ev = delivery ^. #event + modifyIORef' deliveries ((ev ^. #eventId) :) + sinkHandler store 2 ev + pure ShardAckOk + cleanup = do + void (tryPutMVar release ()) + mSuccessor <- readIORef successor + for_ mSuccessor killThread + now <- getCurrentTime + let cleanupWorker = WorkerId sampleUuid2 + _ <- Store.runStoreIO store $ Store.runTransaction $ do + releaseShardsTx sub (WorkerId sampleUuid) [0] + claimShardsTx sub cleanupWorker 1 now 30 + void (reconcileShardsOnce store leaseA opts readersA handlerA) + ( do + Right () <- Store.runStoreIO store (ensureShards leaseA) + void (reconcileShardsOnce store leaseA opts readersA handlerA) + timeout 10_000_000 (takeMVar entered) `shouldReturn` Just () + -- A no longer renews, but its reader remains alive and blocked + -- with one unacknowledged event. B can claim after expiry and + -- must therefore receive that event again from the checkpoint. + threadDelay 2_500_000 + workerB <- forkIO (runShardedSubscriptionGroupAck store sub opts handlerB) + writeIORef successor (Just workerB) + drained <- waitUntilSinkCount store total 20_000_000 + drained `shouldBe` True + raw <- readIORef deliveries + length raw `shouldSatisfy` (> total) + shardSinkCount store `shouldReturn` total + ) + `finally` cleanup + + it "dead-letters a poison event after bounded retries and keeps draining" $ \store -> do + Right () <- Store.runStoreIO store $ Store.runTransaction (Tx.sql createShardSinkSql) + total <- seedOrders store 1 4 + poisonDeliveries <- newIORef (0 :: Int) + errors <- newIORef [] + let sub = SubscriptionName "orders-ack-poison" + opts = + (defaultShardedWorkerOptions (Category (CategoryName "orders")) 1) + { leaseTtl = 3 + , renewInterval = 0.2 + , handlerRetryDelay = KirokuSub.RetryDelay 0.05 + , retryPolicy = KirokuSub.RetryPolicy 3 + , onShardError = Just (\err -> modifyIORef' errors (err :)) + } + handler ev = do + let orderNumber = parseEither (withObject "OrderPlaced" (.: "n")) (ev ^. #payload) + if orderNumber == Right (1 :: Int) + then do + modifyIORef' poisonDeliveries (+ 1) + throwIO (userError "poison order") + else sinkHandler store 1 ev + worker <- forkIO (runShardedSubscriptionGroup store sub opts handler) + drained <- waitUntilSinkCount store (total - 1) 20_000_000 + details <- shardDeadLetterDetails store "orders-ack-poison" + attempts <- readIORef poisonDeliveries + seenErrors <- readIORef errors + killThread worker + drained `shouldBe` True + attempts `shouldBe` 3 + details `shouldBe` (1, Just "max retry attempts exceeded (3)", Just 3) + seenErrors `shouldSatisfy` all (\case ShardReaderDied _ _ -> False; _ -> True) + + describe "Keiro.Workflow observability" $ around (withFreshStore fixture) $ do + -- The headline operability signal: executed (real work) vs replayed + -- (recorded history), recorded by the runtime through an SDK meter and read + -- back from the in-memory exporter — plus the active gauge and the + -- journal-length histogram. + it "records workflow instruments through an SDK meter" $ \storeHandle -> do + (exporter, ref) <- inMemoryMetricExporter + (provider, _env) <- + createMeterProvider + emptyMaterializedResources + defaultSdkMeterProviderOptions{metricExporter = Just exporter} + meter <- getMeter provider Telemetry.keiroInstrumentationLibrary + metrics <- Telemetry.newKeiroMetrics meter + counter <- newIORef (0 :: Int) + let name = WorkflowName "obs" + wid = WorkflowId "obs-1" + opts = defaultWorkflowRunOptions & #metrics .~ Just metrics + -- First run: both steps miss → two executions. + first <- Store.runStoreIO storeHandle $ runWorkflowWith opts name wid (demoWorkflow counter) + first `shouldBe` Right (Completed (1, 2)) + -- Second run, same id: both steps hit → two replays. + second <- Store.runStoreIO storeHandle $ runWorkflowWith opts name wid (demoWorkflow counter) + second `shouldBe` Right (Completed (1, 2)) + -- The side effects ran exactly twice across both runs (the replay run + -- short-circuited every step). + readIORef counter >>= \c -> c `shouldBe` 2 + _ <- forceFlushMeterProvider provider Nothing + exported <- readIORef ref + let scalars = flattenScalarPoints exported + hists = flattenHistogramPoints exported + lookup "keiro.workflow.steps.executed" scalars `shouldBe` Just (IntNumber 2) + lookup "keiro.workflow.steps.replayed" scalars `shouldBe` Just (IntNumber 2) + -- One journal-length observation per completed run (two completions). + [c | (n, c, _) <- hists, n == "keiro.workflow.journal.length"] `shouldBe` [2] + -- Both runs finished, so the live-run count returned to zero. + lookup "keiro.workflow.active" scalars `shouldBe` Just (IntNumber 0) + + -- The resume worker increments keiro.workflow.resumed per re-invocation and + -- samples keiro.workflow.awakeables.pending each pass. + it "records a resume and the pending-awakeable count when the worker re-invokes" $ \storeHandle -> do + (exporter, ref) <- inMemoryMetricExporter + (provider, _env) <- + createMeterProvider + emptyMaterializedResources + defaultSdkMeterProviderOptions{metricExporter = Just exporter} + meter <- getMeter provider Telemetry.keiroInstrumentationLibrary + metrics <- Telemetry.newKeiroMetrics meter + counter <- newIORef (0 :: Int) + let name = WorkflowName "obs-resume" + wid = WorkflowId "obs-r-1" + -- Suspend a workflow so it has a step row but no completion: the resume + -- worker will re-invoke it (and stay Suspended, which still counts as a + -- re-invocation). + suspended <- Store.runStoreIO storeHandle $ runWorkflow name wid (stepThenAwaitWorkflow counter) + suspended `shouldBe` Right Suspended + -- Register one pending awakeable (independent of the suspended workflow's + -- own await) so the pending gauge has something to count. + let aid = awakeableIdToUuid (deterministicAwakeableId (WorkflowName "ext") (WorkflowId "1") "cb") + Right () <- + Store.runStoreIO storeHandle $ Store.runTransaction $ Awk.registerAwakeableTx aid "ext" "1" + -- One resume pass with metrics threaded through the run options. + let registry = Map.singleton name (WorkflowDef (\_wid -> stepThenAwaitWorkflow counter)) + resumeOpts = + defaultWorkflowResumeOptions + & #runOptions + .~ (defaultWorkflowRunOptions & #metrics .~ Just metrics) + Right _summary <- Store.runStoreIO storeHandle $ resumeWorkflowsOnce resumeOpts registry + _ <- forceFlushMeterProvider provider Nothing + exported <- readIORef ref + let scalars = flattenScalarPoints exported + lookup "keiro.workflow.resumed" scalars `shouldBe` Just (IntNumber 1) + lookup "keiro.workflow.awakeables.pending" scalars `shouldBe` Just (IntNumber 1) + + -- The no-op idiom end to end: defaultWorkflowRunOptions carries metrics = + -- Nothing, so a run on a dedicated provider exports no points at all. + it "records nothing through a Nothing handle" $ \storeHandle -> do + (exporter, ref) <- inMemoryMetricExporter + (provider, _env) <- + createMeterProvider + emptyMaterializedResources + defaultSdkMeterProviderOptions{metricExporter = Just exporter} + counter <- newIORef (0 :: Int) + result <- + Store.runStoreIO storeHandle $ + runWorkflow (WorkflowName "obs-noop") (WorkflowId "obs-n-1") (demoWorkflow counter) + result `shouldBe` Right (Completed (1, 2)) + _ <- forceFlushMeterProvider provider Nothing + exported <- readIORef ref + flattenScalarPoints exported `shouldBe` [] + flattenHistogramPoints exported `shouldBe` [] + + describe "Keiro.Workflow.Snapshot codec" $ do + -- Pure (no-DB) round-trip of the workflow state codec. + it "round-trips a non-trivial accumulated step map and carries the sentinel shape hash" $ do + let m = + Map.fromList + [ ("first", toJSON (1 :: Int)) + , ("second", toJSON ["a", "b" :: Text]) + , ("sleep:42", Aeson.Null) + ] + (workflowStateCodec ^. #decode) ((workflowStateCodec ^. #encode) m) `shouldBe` Right m + (workflowStateCodec ^. #shapeHash) `shouldBe` "keiro.workflow.stepmap.v1" + (workflowStateCodec ^. #stateCodecVersion) `shouldBe` 1 + + describe "Keiro.Workflow.Types journal codec" $ do + -- Pure (no-DB) round-trip of the EP-48 rotation marker, proving the + -- additive WorkflowContinuedAsNew constructor encodes and decodes + -- self-describingly within schemaVersion 1. + it "round-trips a WorkflowContinuedAsNew rotation marker" $ do + let t = UTCTime (ModifiedJulianDay 60000) (secondsToDiffTime 3600) + marker = WorkflowContinuedAsNew 3 t + (workflowJournalCodec ^. #decode) ((workflowJournalCodec ^. #eventType) marker) ((workflowJournalCodec ^. #encode) marker) + `shouldBe` Right marker + (workflowJournalCodec ^. #schemaVersion) `shouldBe` 1 + EventType "WorkflowContinuedAsNew" `elem` (workflowJournalCodec ^. #eventTypes) `shouldBe` True + + it "validates workflow identity smart constructors" $ do + mkWorkflowName "orderFulfillment" `shouldBe` Right (WorkflowName "orderFulfillment") + mkWorkflowName "" `shouldBe` Left WorkflowNameEmpty + mkWorkflowName "order-fulfillment" `shouldBe` Left (WorkflowNameInvalidChar '-' "order-fulfillment") + mkWorkflowName "order:fulfillment" `shouldBe` Left (WorkflowNameInvalidChar ':' "order:fulfillment") + mkWorkflowName "order#1" `shouldBe` Left (WorkflowNameInvalidChar '#' "order#1") + mkWorkflowId "550e8400-e29b-41d4-a716-446655440000" + `shouldBe` Right (WorkflowId "550e8400-e29b-41d4-a716-446655440000") + mkWorkflowId "" `shouldBe` Left WorkflowIdEmpty + mkWorkflowId "customer:42" `shouldBe` Left (WorkflowIdInvalidChar ':' "customer:42") + mkWorkflowId "customer#42" `shouldBe` Left (WorkflowIdInvalidChar '#' "customer#42") + + describe "Keiro.Workflow.Sleep" $ do + -- Pure (no-DB) checks of the id/payload/step-name helpers. + it "derives a deterministic, distinct timer id" $ do + let name = WorkflowName "wf" + wid = WorkflowId "w-1" + sleepGolden = uuidLiteral "a95d5e7f-a43d-5ee2-9243-8206f0d8734a" + sleepTimerId name wid 0 "sleep:cool" `shouldBe` sleepTimerId name wid 0 "sleep:cool" + (sleepTimerId name wid 0 "sleep:cool" == sleepTimerId name wid 0 "sleep:other") + `shouldBe` False + sleepTimerId name wid 0 "sleep:cool" + `shouldBe` TimerId sleepGolden + sleepTimerId name wid 1 "sleep:cool" `shouldNotBe` sleepTimerId name wid 0 "sleep:cool" + sleepTimerId name wid 2 "sleep:cool" `shouldNotBe` sleepTimerId name wid 1 "sleep:cool" + + it "round-trips and recognises its timer payload" $ do + parseSleepPayload (sleepTimerPayload "sleep:cool") `shouldBe` Just "sleep:cool" + parseSleepPayload (object ["kind" Aeson..= ("counter-timeout" :: Text)]) + `shouldBe` Nothing + + it "prefixes the journal step name with the reserved sleep prefix" $ + sleepStepName (StepName "cool") `shouldBe` "sleep:cool" + + around (withFreshStore fixture) $ do + it "arms a timer and suspends, then a fired timer resumes the workflow" $ \storeHandle -> do + counter <- newIORef (0 :: Int) + let name = WorkflowName "sleepdemo" + wid = WorkflowId "sd-1" + journalStream = StreamName "wf:sleepdemo-sd-1" + TimerId timerUuid = sleepTimerId name wid 0 "sleep:cool" + -- First run: 'a' runs, the sleep arms a timer, and the run suspends. + outcome1 <- + Store.runStoreIO storeHandle $ + runWorkflow name wid (sleepDemoNamed counter (StepName "cool") 0) + outcome1 `shouldBe` Right Suspended + afterFirst <- readIORef counter + afterFirst `shouldBe` 1 + -- The journal holds only 'a' (no completion, no sleep:cool yet). + Right recorded1 <- + Store.runStoreIO storeHandle $ + Store.readStreamForward journalStream (StreamVersion 0) 100 + traverse (decodeRecorded workflowJournalCodec) (Vector.toList recorded1) + `shouldSatisfy` \case + Right [StepRecorded "a" _ _] -> True + _ -> False + -- The durable wait is a single Scheduled timer row carrying the + -- workflow-sleep payload. + Right timerRow <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + Tx.statement timerUuid sleepTimerStatusStmt + timerRow `shouldSatisfy` \case + Just (status, payload) -> + status == "scheduled" && parseSleepPayload payload == Just "sleep:cool" + Nothing -> False + -- Fire the timer through the routing worker (no PM fallback needed). + fireTime <- getCurrentTime + fireResult <- + Store.runStoreIO storeHandle $ + runWorkflowTimerWorker Nothing fireTime (\_ -> pure Nothing) + case fireResult of + Right (Just timer) -> timer ^. #status `shouldBe` Firing + other -> expectationFailure ("expected a fired sleep timer, got " <> show other) + -- The row is now Fired and the journal gained sleep:cool. + Right afterFire <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + Tx.statement timerUuid sleepTimerStatusStmt + fmap fst afterFire `shouldBe` Just "fired" + Right recorded2 <- + Store.runStoreIO storeHandle $ + Store.readStreamForward journalStream (StreamVersion 0) 100 + traverse (decodeRecorded workflowJournalCodec) (Vector.toList recorded2) + `shouldSatisfy` \case + Right [StepRecorded "a" _ _, StepRecorded "sleep:cool" _ _] -> True + _ -> False + -- Second run completes: 'a' and the sleep short-circuit, only 'b' runs. + outcome2 <- + Store.runStoreIO storeHandle $ + runWorkflow name wid (sleepDemoNamed counter (StepName "cool") 0) + outcome2 `shouldBe` Right (Completed (1, 2)) + afterSecond <- readIORef counter + afterSecond `shouldBe` 2 + Right recorded3 <- + Store.runStoreIO storeHandle $ + Store.readStreamForward journalStream (StreamVersion 0) 100 + traverse (decodeRecorded workflowJournalCodec) (Vector.toList recorded3) + `shouldSatisfy` \case + Right [StepRecorded "a" _ _, StepRecorded "sleep:cool" _ _, StepRecorded "b" _ _, WorkflowCompleted _] -> True + _ -> False + + it "respects a positive delay: not due before fire_at, fires after" $ \storeHandle -> do + counter <- newIORef (0 :: Int) + let name = WorkflowName "sleepwait" + wid = WorkflowId "rt-1" + journalStream = StreamName "wf:sleepwait-rt-1" + clockBeforeFire <- getCurrentTime + outcome1 <- + Store.runStoreIO storeHandle $ + runWorkflow name wid (sleepDemoNamed counter (StepName "wait") 1) + outcome1 `shouldBe` Right Suspended + afterFirst <- readIORef counter + afterFirst `shouldBe` 1 + -- A worker whose clock is before fire_at claims nothing. + notDue <- + Store.runStoreIO storeHandle $ + runTimerWorker Nothing clockBeforeFire workflowSleepFireAction + notDue `shouldBe` Right Nothing + Right recordedMid <- + Store.runStoreIO storeHandle $ + Store.readStreamForward journalStream (StreamVersion 0) 100 + traverse (decodeRecorded workflowJournalCodec) (Vector.toList recordedMid) + `shouldSatisfy` \case + Right [StepRecorded "a" _ _] -> True + _ -> False + -- Wait out the one-second delay, then the worker fires it. + threadDelay 1_200_000 + afterDelay <- getCurrentTime + fired <- + Store.runStoreIO storeHandle $ + runTimerWorker Nothing afterDelay workflowSleepFireAction + fired `shouldSatisfy` \case + Right (Just _) -> True + _ -> False + Right recordedWoken <- + Store.runStoreIO storeHandle $ + Store.readStreamForward journalStream (StreamVersion 0) 100 + traverse (decodeRecorded workflowJournalCodec) (Vector.toList recordedWoken) + `shouldSatisfy` \case + Right [StepRecorded "a" _ _, StepRecorded "sleep:wait" _ _] -> True + _ -> False + outcome2 <- + Store.runStoreIO storeHandle $ + runWorkflow name wid (sleepDemoNamed counter (StepName "wait") 1) + outcome2 `shouldBe` Right (Completed (1, 2)) + afterSecond <- readIORef counter + afterSecond `shouldBe` 2 + + it "does not postpone fire_at when a resume pass re-arms the sleep" $ \storeHandle -> do + counter <- newIORef (0 :: Int) + let name = WorkflowName "sleeponce" + wid = WorkflowId "so-1" + TimerId timerUuid = sleepTimerId name wid 0 "sleep:cool" + registry = Map.singleton name (WorkflowDef (\_ -> sleepDemoNamed counter (StepName "cool") 300)) + Right Suspended <- + Store.runStoreIO storeHandle $ + runWorkflow name wid (sleepDemoNamed counter (StepName "cool") 300) + Right (Just firstFireAt) <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + Tx.statement timerUuid sleepTimerFireAtStmt + Right summary <- + Store.runStoreIO storeHandle $ + resumeWorkflowsOnce defaultWorkflowResumeOptions registry + discovered summary `shouldBe` 0 + Right (Just secondFireAt) <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + Tx.statement timerUuid sleepTimerFireAtStmt + secondFireAt `shouldBe` firstFireAt + readIORef counter >>= (`shouldBe` 1) + + it "skips a sleeping workflow until wake_after expires" $ \storeHandle -> do + counter <- newIORef (0 :: Int) + let name = WorkflowName "sleepwakeafter" + wid = WorkflowId "swa-1" + Right Suspended <- + Store.runStoreIO storeHandle $ + runWorkflow name wid (sleepDemoNamed counter (StepName "wait") 60) + now <- getCurrentTime + Right mWakeAfter <- Store.runStoreIO storeHandle $ workflowWakeAfter name wid + case mWakeAfter of + Nothing -> expectationFailure "expected wake_after" + Just wakeAfter -> wakeAfter `shouldSatisfy` (> now) + Right early <- Store.runStoreIO storeHandle $ findUnfinishedWorkflowIds now + early `shouldBe` [] + Right due <- Store.runStoreIO storeHandle $ findUnfinishedWorkflowIds (addUTCTime 61 now) + due `shouldBe` [("swa-1", "sleepwakeafter")] + + it "does not re-invoke a parked sleeper before wake_after" $ \storeHandle -> do + counter <- newIORef (0 :: Int) + let name = WorkflowName "sleepquiet" + wid = WorkflowId "sq-1" + registry = Map.singleton name (WorkflowDef (\_ -> sleepDemoNamed counter (StepName "wait") 60)) + pass = Store.runStoreIO storeHandle (resumeWorkflowsOnce defaultWorkflowResumeOptions registry) + Right Suspended <- + Store.runStoreIO storeHandle $ + runWorkflow name wid (sleepDemoNamed counter (StepName "wait") 60) + Right s1 <- pass + Right s2 <- pass + Right s3 <- pass + map discovered [s1, s2, s3] `shouldBe` [0, 0, 0] + readIORef counter >>= (`shouldBe` 1) + + it "treats a missing instance row during sleep arm as a no-op wake hint update" $ \storeHandle -> do + let name = WorkflowName "sleepmissingrow" + wid = WorkflowId "smr-1" + body = sleepNamed (StepName "wait") 60 >> pure () + Right Suspended <- Store.runStoreIO storeHandle $ runWorkflow name wid body + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + Tx.statement ("smr-1", "sleepmissingrow") deleteWorkflowInstanceStmt + Store.runStoreIO storeHandle (runWorkflow name wid body) + `shouldReturn` Right Suspended + + it "fires a sleep longer than the resume cadence under an active resume worker" $ \storeHandle -> do + counter <- newIORef (0 :: Int) + let name = WorkflowName "sleepactive" + wid = WorkflowId "sa-1" + registry = Map.singleton name (WorkflowDef (\_ -> sleepDemoNamed counter (StepName "wait") 1)) + drive 0 = expectationFailure "active resume cadence kept postponing the sleep" + drive n = do + Right summary <- + Store.runStoreIO storeHandle $ + resumeWorkflowsOnce defaultWorkflowResumeOptions registry + now <- getCurrentTime + _ <- + Store.runStoreIO storeHandle $ + runWorkflowTimerWorker Nothing now (\_ -> pure Nothing) + if completed summary == 1 + then pure () + else threadDelay 250_000 >> drive (n - 1) + Right Suspended <- + Store.runStoreIO storeHandle $ + runWorkflow name wid (sleepDemoNamed counter (StepName "wait") 1) + drive (16 :: Int) + readIORef counter >>= (`shouldBe` 2) + + it "uses generation-namespaced timer ids after continueAsNew" $ \storeHandle -> do + counter <- newIORef (0 :: Int) + let name = WorkflowName "sleeproll" + wid = WorkflowId "sr-1" + registry = Map.singleton name (WorkflowDef (\_ -> rollingSleepWorkflow counter)) + drive 0 = expectationFailure "rolling sleep did not complete" + drive n = do + Right summary <- + Store.runStoreIO storeHandle $ + resumeWorkflowsOnce defaultWorkflowResumeOptions registry + now <- getCurrentTime + _ <- + Store.runStoreIO storeHandle $ + runWorkflowTimerWorker Nothing now (\_ -> pure Nothing) + if completed summary == 1 + then pure () + else drive (n - 1) + Right Suspended <- Store.runStoreIO storeHandle $ runWorkflow name wid (rollingSleepWorkflow counter) + drive (12 :: Int) + readIORef counter >>= (`shouldBe` 3) + + describe "Keiro.Workflow.Awakeable" $ do + -- Pure (no-DB) check of the deterministic id derivation. + it "derives a deterministic AwakeableId, stable across calls and label-sensitive" $ do + let aid1 = deterministicAwakeableId (WorkflowName "w") (WorkflowId "1") "approval" + aid2 = deterministicAwakeableId (WorkflowName "w") (WorkflowId "1") "approval" + aidOther = deterministicAwakeableId (WorkflowName "w") (WorkflowId "1") "other" + awakeableGolden = uuidLiteral "ccaeaf74-3ffe-5ea5-a118-a3441a95c279" + aid1 `shouldBe` aid2 + (aid1 == aidOther) `shouldBe` False + aid1 `shouldBe` AwakeableId awakeableGolden + + around (withFreshStore fixture) $ do + it "schema: registers, completes once (idempotent), cancels, and counts pending rows" $ \storeHandle -> do + let aidA = awakeableIdToUuid (deterministicAwakeableId (WorkflowName "sch") (WorkflowId "1") "a") + aidB = awakeableIdToUuid (deterministicAwakeableId (WorkflowName "sch") (WorkflowId "1") "b") + now <- getCurrentTime + Right () <- Store.runStoreIO storeHandle $ Store.runTransaction $ do + Awk.registerAwakeableTx aidA "sch" "1" + Awk.registerAwakeableTx aidB "sch" "1" + Right pendingCount <- Store.runStoreIO storeHandle Awk.countPendingAwakeables + pendingCount `shouldBe` 2 + Right (Just rowA) <- Store.runStoreIO storeHandle $ Awk.lookupAwakeable aidA + rowA ^. #status `shouldBe` Awk.Pending + rowA ^. #payload `shouldBe` Nothing + -- Complete A once; the status-guarded UPDATE makes a re-complete a no-op. + Right firstComplete <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + Awk.completeAwakeableTx aidA (toJSON ("done" :: Text)) now + firstComplete `shouldBe` True + Right secondComplete <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + Awk.completeAwakeableTx aidA (toJSON ("again" :: Text)) now + secondComplete `shouldBe` False + Right (Just rowA') <- Store.runStoreIO storeHandle $ Awk.lookupAwakeable aidA + rowA' ^. #status `shouldBe` Awk.Completed + rowA' ^. #payload `shouldBe` Just (toJSON ("done" :: Text)) + -- Cancel the still-pending B; both rows are now resolved. + Right cancelled <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + Awk.cancelAwakeableTx aidB + cancelled `shouldBe` True + Right pendingAfter <- Store.runStoreIO storeHandle Awk.countPendingAwakeables + pendingAfter `shouldBe` 0 + + it "suspends on an unsignalled awakeable, recording a pending row and no completion" $ \storeHandle -> do + aidRef <- newIORef Nothing + let name = WorkflowName "approval" + wid = WorkflowId "wf1" + outcome1 <- Store.runStoreIO storeHandle $ runWorkflow name wid (approvalFlowWithId aidRef) + outcome1 `shouldBe` Right Suspended + aid <- readRequiredAwakeableId aidRef + Right (Just row) <- Store.runStoreIO storeHandle $ Awk.lookupAwakeable (awakeableIdToUuid aid) + row ^. #status `shouldBe` Awk.Pending + row ^. #payload `shouldBe` Nothing + Right pendingNow <- Store.runStoreIO storeHandle Awk.countPendingAwakeables + pendingNow `shouldBe` 1 + Right recorded <- + Store.runStoreIO storeHandle $ + Store.readStreamForward (StreamName "wf:approval-wf1") (StreamVersion 0) 100 + traverse (decodeRecorded workflowJournalCodec) (Vector.toList recorded) + `shouldSatisfy` \case + Right [StepRecorded stepName value _] -> + stepName == awakeableAllocStepPrefix <> "approval" && value == toJSON aid + _ -> False + + it "resumes with the signalled payload after signalAwakeable" $ \storeHandle -> do + aidRef <- newIORef Nothing + let name = WorkflowName "approval" + wid = WorkflowId "wf1" + Right Suspended <- Store.runStoreIO storeHandle $ runWorkflow name wid (approvalFlowWithId aidRef) + aid <- readRequiredAwakeableId aidRef + let awkStep = "awk:" <> awakeableIdText aid + Right signalled <- Store.runStoreIO storeHandle $ signalAwakeable aid ("ok" :: Text) + signalled `shouldBe` True + Right (Just row) <- Store.runStoreIO storeHandle $ Awk.lookupAwakeable (awakeableIdToUuid aid) + row ^. #status `shouldBe` Awk.Completed + row ^. #payload `shouldBe` Just (toJSON ("ok" :: Text)) + Right afterSignal <- + Store.runStoreIO storeHandle $ + Store.readStreamForward (StreamName "wf:approval-wf1") (StreamVersion 0) 100 + traverse (decodeRecorded workflowJournalCodec) (Vector.toList afterSignal) + `shouldSatisfy` \case + Right [StepRecorded allocStep _ _, StepRecorded s r _] -> + allocStep == awakeableAllocStepPrefix <> "approval" && s == awkStep && r == toJSON ("ok" :: Text) + _ -> False + outcome2 <- Store.runStoreIO storeHandle $ runWorkflow name wid (approvalFlowWithId aidRef) + outcome2 `shouldBe` Right (Completed "ok!") + Right afterResume <- + Store.runStoreIO storeHandle $ + Store.readStreamForward (StreamName "wf:approval-wf1") (StreamVersion 0) 100 + traverse (decodeRecorded workflowJournalCodec) (Vector.toList afterResume) + `shouldSatisfy` \case + Right [StepRecorded allocStep _ _, StepRecorded s1 _ _, StepRecorded "use" _ _, WorkflowCompleted _] -> + allocStep == awakeableAllocStepPrefix <> "approval" && s1 == awkStep + _ -> False + + it "is idempotent: a second signal returns False and does not change the value" $ \storeHandle -> do + aidRef <- newIORef Nothing + let name = WorkflowName "idem" + wid = WorkflowId "wf-i" + Right Suspended <- Store.runStoreIO storeHandle $ runWorkflow name wid (approvalFlowWithId aidRef) + aid <- readRequiredAwakeableId aidRef + let awkStep = "awk:" <> awakeableIdText aid + Right True <- Store.runStoreIO storeHandle $ signalAwakeable aid ("ok" :: Text) + Right again <- Store.runStoreIO storeHandle $ signalAwakeable aid ("later" :: Text) + again `shouldBe` False + Right (Just row) <- Store.runStoreIO storeHandle $ Awk.lookupAwakeable (awakeableIdToUuid aid) + row ^. #payload `shouldBe` Just (toJSON ("ok" :: Text)) + Right recorded <- + Store.runStoreIO storeHandle $ + Store.readStreamForward (StreamName "wf:idem-wf-i") (StreamVersion 0) 100 + Right decoded <- pure (traverse (decodeRecorded workflowJournalCodec) (Vector.toList recorded)) + [r | StepRecorded s r _ <- decoded, s == awkStep] `shouldBe` [toJSON ("ok" :: Text)] + + it "throws WorkflowAwakeableCancelled after cancelAwakeable" $ \storeHandle -> do + aidRef <- newIORef Nothing + let name = WorkflowName "cancelwf" + wid = WorkflowId "wf2" + Right Suspended <- Store.runStoreIO storeHandle $ runWorkflow name wid (approvalFlowWithId aidRef) + aid <- readRequiredAwakeableId aidRef + Right cancelled <- Store.runStoreIO storeHandle $ cancelAwakeable aid + cancelled `shouldBe` True + Right (Just row) <- Store.runStoreIO storeHandle $ Awk.lookupAwakeable (awakeableIdToUuid aid) + row ^. #status `shouldBe` Awk.Cancelled + Store.runStoreIO storeHandle (runWorkflow name wid (approvalFlowWithId aidRef)) + `shouldThrow` (== WorkflowAwakeableCancelled aid) + Right recorded <- + Store.runStoreIO storeHandle $ + Store.readStreamForward (StreamName "wf:cancelwf-wf2") (StreamVersion 0) 100 + Right decoded <- pure (traverse (decodeRecorded workflowJournalCodec) (Vector.toList recorded)) + any (\case WorkflowCompleted{} -> True; _ -> False) decoded `shouldBe` False + + it "re-appends a missing journal entry when re-signalled (crash-safe)" $ \storeHandle -> do + aidRef <- newIORef Nothing + let name = WorkflowName "crash" + wid = WorkflowId "wf3" + Right Suspended <- Store.runStoreIO storeHandle $ runWorkflow name wid (approvalFlowWithId aidRef) + aid <- readRequiredAwakeableId aidRef + let awkStep = "awk:" <> awakeableIdText aid + -- Simulate "row completed but the journal append did not happen" by + -- completing the row directly, bypassing signalAwakeable's journal write. + now <- getCurrentTime + Right completedRow <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + Awk.completeAwakeableTx (awakeableIdToUuid aid) (toJSON ("ok" :: Text)) now + completedRow `shouldBe` True + Right beforeRepair <- + Store.runStoreIO storeHandle $ + Store.readStreamForward (StreamName "wf:crash-wf3") (StreamVersion 0) 100 + Right beforeDecoded <- pure (traverse (decodeRecorded workflowJournalCodec) (Vector.toList beforeRepair)) + [() | StepRecorded s _ _ <- beforeDecoded, s == awkStep] `shouldBe` [] + -- A re-signal with the same payload returns False (already completed) but + -- repairs the missing journal entry from the stored payload. + Right repaired <- Store.runStoreIO storeHandle $ signalAwakeable aid ("ok" :: Text) + repaired `shouldBe` False + Right afterRepair <- + Store.runStoreIO storeHandle $ + Store.readStreamForward (StreamName "wf:crash-wf3") (StreamVersion 0) 100 + Right afterDecoded <- pure (traverse (decodeRecorded workflowJournalCodec) (Vector.toList afterRepair)) + [r | StepRecorded s r _ <- afterDecoded, s == awkStep] `shouldBe` [toJSON ("ok" :: Text)] + + it "repairs a completed awakeable row from the await arm without a second signal" $ \storeHandle -> do + aidRef <- newIORef Nothing + let name = WorkflowName "crash-arm" + wid = WorkflowId "wf4" + Right Suspended <- Store.runStoreIO storeHandle $ runWorkflow name wid (approvalFlowWithId aidRef) + aid <- readRequiredAwakeableId aidRef + let awkStep = "awk:" <> awakeableIdText aid + now <- getCurrentTime + Right True <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + Awk.completeAwakeableTx (awakeableIdToUuid aid) (toJSON ("ok" :: Text)) now + repairedRun <- Store.runStoreIO storeHandle $ runWorkflow name wid (approvalFlowWithId aidRef) + repairedRun `shouldBe` Right Suspended + Right repairedJournal <- + Store.runStoreIO storeHandle $ + Store.readStreamForward (StreamName "wf:crash-arm-wf4") (StreamVersion 0) 100 + Right repairedDecoded <- pure (traverse (decodeRecorded workflowJournalCodec) (Vector.toList repairedJournal)) + [r | StepRecorded s r _ <- repairedDecoded, s == awkStep] `shouldBe` [toJSON ("ok" :: Text)] + completed <- Store.runStoreIO storeHandle $ runWorkflow name wid (approvalFlowWithId aidRef) + completed `shouldBe` Right (Completed "ok!") + + it "refuses a forged coordinate-derived id for a fresh awakeable" $ \storeHandle -> do + aidRef <- newIORef Nothing + let name = WorkflowName "fresh-awake" + wid = WorkflowId "fa-1" + forged = deterministicAwakeableId name wid "approval" + Right Suspended <- Store.runStoreIO storeHandle $ runWorkflow name wid (approvalFlowWithId aidRef) + real <- readRequiredAwakeableId aidRef + real `shouldNotBe` forged + Right forgedSignal <- Store.runStoreIO storeHandle $ signalAwakeable forged ("bad" :: Text) + forgedSignal `shouldBe` False + Right stillSuspended <- Store.runStoreIO storeHandle $ runWorkflow name wid (approvalFlowWithId aidRef) + stillSuspended `shouldBe` Suspended + Right realSignal <- Store.runStoreIO storeHandle $ signalAwakeable real ("ok" :: Text) + realSignal `shouldBe` True + completed <- Store.runStoreIO storeHandle $ runWorkflow name wid (approvalFlowWithId aidRef) + completed `shouldBe` Right (Completed "ok!") + + it "adopts a generation-0 legacy deterministic row" $ \storeHandle -> do + aidRef <- newIORef Nothing + let name = WorkflowName "legacy-awake" + wid = WorkflowId "la-1" + legacy = deterministicAwakeableId name wid "approval" + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + Awk.registerAwakeableTx (awakeableIdToUuid legacy) (unWorkflowName name) (unWorkflowId wid) + Right Suspended <- Store.runStoreIO storeHandle $ runWorkflow name wid (approvalFlowWithId aidRef) + adopted <- readRequiredAwakeableId aidRef + adopted `shouldBe` legacy + Right True <- Store.runStoreIO storeHandle $ signalAwakeable legacy ("ok" :: Text) + completed <- Store.runStoreIO storeHandle $ runWorkflow name wid (approvalFlowWithId aidRef) + completed `shouldBe` Right (Completed "ok!") + + it "allocates a fresh awakeable for the same label after continueAsNew" $ \storeHandle -> do + idsRef <- newIORef [] + let name = WorkflowName "awake-roll" + wid = WorkflowId "ar-1" + body = rollingAwakeableWorkflow idsRef + Right Suspended <- Store.runStoreIO storeHandle $ runWorkflow name wid body + ids1 <- readIORef idsRef + [firstAid] <- pure ids1 + Right True <- Store.runStoreIO storeHandle $ signalAwakeable firstAid ("first" :: Text) + Right ContinuedAsNew <- Store.runStoreIO storeHandle $ runWorkflow name wid body + Right Suspended <- Store.runStoreIO storeHandle $ runWorkflow name wid body + ids2 <- readIORef idsRef + case ids2 of + [firstAgain, secondAid] -> do + firstAgain `shouldBe` firstAid + secondAid `shouldNotBe` firstAid + Right staleSignal <- Store.runStoreIO storeHandle $ signalAwakeable firstAid ("stale" :: Text) + staleSignal `shouldBe` False + Right stillSuspended <- Store.runStoreIO storeHandle $ runWorkflow name wid body + stillSuspended `shouldBe` Suspended + Right True <- Store.runStoreIO storeHandle $ signalAwakeable secondAid ("second" :: Text) + completed <- Store.runStoreIO storeHandle $ runWorkflow name wid body + completed `shouldBe` Right (Completed "second") + other -> expectationFailure ("expected two awakeable ids, got " <> show other) + + describe "Keiro.Workflow.Child" $ do + -- M2: the reserved spawn/result step-name derivations are stable. + it "derives the child spawn and result step names" $ do + childSpawnStepName (WorkflowId "c1") `shouldBe` "child:c1" + childResultStepName (WorkflowId "c1") `shouldBe` "child:c1:result" + + -- M3(a): the new terminal journal constructors round-trip through the codec. + it "round-trips WorkflowCancelled and WorkflowFailed through the journal codec" $ do + let t = UTCTime (ModifiedJulianDay 0) 0 + rt ev = (workflowJournalCodec ^. #decode) ((workflowJournalCodec ^. #eventType) ev) ((workflowJournalCodec ^. #encode) ev) + rt (WorkflowCancelled t) `shouldBe` Right (WorkflowCancelled t) + rt (WorkflowFailed "boom" t) `shouldBe` Right (WorkflowFailed "boom" t) + + around (withFreshStore fixture) $ do + -- M1: the keiro_workflow_children table and its schema helpers. + it "schema: registers, completes, cancels, and counts child links" $ \storeHandle -> do + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + Child.registerChildTx "c-1" "ship" "p-1" "parent" "child:c-1:result" + Right (Just row) <- Store.runStoreIO storeHandle $ Child.lookupChild "c-1" "ship" + row ^. #status `shouldBe` Child.Running + row ^. #parentId `shouldBe` "p-1" + row ^. #parentName `shouldBe` "parent" + row ^. #awaitStep `shouldBe` "child:c-1:result" + now <- getCurrentTime + Right firstComplete <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + Child.markChildResultTx "c-1" "ship" (toJSON ("packed+labelled" :: Text)) now + firstComplete `shouldBe` True + Right secondComplete <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + Child.markChildResultTx "c-1" "ship" (toJSON ("again" :: Text)) now + secondComplete `shouldBe` False + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + Child.registerChildTx "c-2" "ship" "p-1" "parent" "child:c-2:result" + Right cancelled <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + Child.markChildCancelledTx "c-2" "ship" + cancelled `shouldBe` True + Right kids <- Store.runStoreIO storeHandle $ Child.lookupChildrenOfParent "p-1" "parent" + map (^. #childId) kids `shouldBe` ["c-1", "c-2"] + Right active <- Store.runStoreIO storeHandle Child.countActiveChildren + active `shouldBe` (0 :: Int) + Right st <- Store.runStoreIO storeHandle $ Child.childStatus "c-1" "ship" + st `shouldBe` Just Child.ChildCompleted + + -- M4: spawn -> drive the child (with the completion hook) -> resume parent. + it "spawns a child, drives it, propagates its result, and resumes the parent to Completed" $ \storeHandle -> do + let childWid = WorkflowId "ship-1" + suspended <- + Store.runStoreIO storeHandle $ + runWorkflow (WorkflowName "parent") (WorkflowId "p1") (parentWorkflow childWid) + suspended `shouldBe` Right Suspended + Right parentJournal1 <- + Store.runStoreIO storeHandle $ + Store.readStreamForward (StreamName "wf:parent-p1") (StreamVersion 0) 10 + Right decoded1 <- pure (traverse (decodeRecorded workflowJournalCodec) (Vector.toList parentJournal1)) + decoded1 `shouldSatisfy` \case + [StepRecorded "child:ship-1" _ _] -> True + _ -> False + Right (Just childRow) <- Store.runStoreIO storeHandle $ Child.lookupChild "ship-1" "ship" + childRow ^. #status `shouldBe` Child.Running + childRow ^. #parentId `shouldBe` "p1" + childRow ^. #parentName `shouldBe` "parent" + childRow ^. #awaitStep `shouldBe` "child:ship-1:result" + -- 2) drive the child through runChildWorkflow (propagates on completion). + childOutcome <- + Store.runStoreIO storeHandle $ + runChildWorkflow defaultWorkflowRunOptions (WorkflowName "ship") childWid shipWorkflow + childOutcome `shouldBe` Right (Completed "packed+labelled") + Right childJournal <- + Store.runStoreIO storeHandle $ + Store.readStreamForward (StreamName "wf:ship-ship-1") (StreamVersion 0) 10 + traverse (decodeRecorded workflowJournalCodec) (Vector.toList childJournal) + `shouldSatisfy` \case + Right [StepRecorded "pack" _ _, StepRecorded "label" _ _, WorkflowCompleted _] -> True + _ -> False + Right parentJournal2 <- + Store.runStoreIO storeHandle $ + Store.readStreamForward (StreamName "wf:parent-p1") (StreamVersion 0) 10 + Right decoded2 <- pure (traverse (decodeRecorded workflowJournalCodec) (Vector.toList parentJournal2)) + [r | StepRecorded "child:ship-1:result" r _ <- decoded2] + `shouldBe` [object ["ok" Aeson..= ("packed+labelled" :: Text)]] + Right (Just childRow2) <- Store.runStoreIO storeHandle $ Child.lookupChild "ship-1" "ship" + childRow2 ^. #status `shouldBe` Child.ChildCompleted + -- 3) resume the parent: it replays past awaitChild and completes. + resumed <- + Store.runStoreIO storeHandle $ + runWorkflow (WorkflowName "parent") (WorkflowId "p1") (parentWorkflow childWid) + resumed `shouldBe` Right (Completed "done:packed+labelled") + Right parentJournal3 <- + Store.runStoreIO storeHandle $ + Store.readStreamForward (StreamName "wf:parent-p1") (StreamVersion 0) 10 + Right decoded3 <- pure (traverse (decodeRecorded workflowJournalCodec) (Vector.toList parentJournal3)) + any (\case StepRecorded "notify" _ _ -> True; _ -> False) decoded3 `shouldBe` True + any (\case WorkflowCompleted{} -> True; _ -> False) decoded3 `shouldBe` True + + it "repairs a completed child row from awaitChild without another completion hook" $ \storeHandle -> do + let childWid = WorkflowId "ship-crash" + Right Suspended <- + Store.runStoreIO storeHandle $ + runWorkflow (WorkflowName "parent") (WorkflowId "p-crash") (parentWorkflow childWid) + now <- getCurrentTime + Right transitioned <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + Child.markChildResultTx "ship-crash" "ship" (toJSON ("packed+labelled" :: Text)) now + transitioned `shouldBe` True + Right beforeRepair <- + Store.runStoreIO storeHandle $ + Store.readStreamForward (StreamName "wf:parent-p-crash") (StreamVersion 0) 10 + Right beforeDecoded <- pure (traverse (decodeRecorded workflowJournalCodec) (Vector.toList beforeRepair)) + [r | StepRecorded "child:ship-crash:result" r _ <- beforeDecoded] `shouldBe` [] + repaired <- + Store.runStoreIO storeHandle $ + runWorkflow (WorkflowName "parent") (WorkflowId "p-crash") (parentWorkflow childWid) + repaired `shouldBe` Right Suspended + Right afterRepair <- + Store.runStoreIO storeHandle $ + Store.readStreamForward (StreamName "wf:parent-p-crash") (StreamVersion 0) 10 + Right afterDecoded <- pure (traverse (decodeRecorded workflowJournalCodec) (Vector.toList afterRepair)) + [r | StepRecorded "child:ship-crash:result" r _ <- afterDecoded] + `shouldBe` [object ["ok" Aeson..= ("packed+labelled" :: Text)]] + completed <- + Store.runStoreIO storeHandle $ + runWorkflow (WorkflowName "parent") (WorkflowId "p-crash") (parentWorkflow childWid) + completed `shouldBe` Right (Completed "done:packed+labelled") + + -- M5: re-invoking the parent does not re-spawn the child (crash survival). + it "does not re-spawn the child when the parent is re-invoked" $ \storeHandle -> do + let childWid = WorkflowId "ship-2" + s1 <- + Store.runStoreIO storeHandle $ + runWorkflow (WorkflowName "parent") (WorkflowId "p2") (parentWorkflow childWid) + s1 `shouldBe` Right Suspended + Right (Just beforeRow) <- Store.runStoreIO storeHandle $ Child.lookupChild "ship-2" "ship" + let createdAt0 = beforeRow ^. #createdAt + s2 <- + Store.runStoreIO storeHandle $ + runWorkflow (WorkflowName "parent") (WorkflowId "p2") (parentWorkflow childWid) + s2 `shouldBe` Right Suspended + Right parentJournal <- + Store.runStoreIO storeHandle $ + Store.readStreamForward (StreamName "wf:parent-p2") (StreamVersion 0) 10 + Right decoded <- pure (traverse (decodeRecorded workflowJournalCodec) (Vector.toList parentJournal)) + length [() | StepRecorded "child:ship-2" _ _ <- decoded] `shouldBe` 1 + Right kids <- Store.runStoreIO storeHandle $ Child.lookupChildrenOfParent "p2" "parent" + length kids `shouldBe` 1 + map (^. #createdAt) kids `shouldBe` [createdAt0] + + -- M5: cancelling a child stops it and makes the parent's awaitChild throw. + it "cancels a child: the child stops and the parent's awaitChild throws" $ \storeHandle -> do + let childWid = WorkflowId "cancel-child" + h = ChildHandle (WorkflowName "ship") childWid + s1 <- + Store.runStoreIO storeHandle $ + runWorkflow (WorkflowName "parent") (WorkflowId "p3") (parentWorkflow childWid) + s1 `shouldBe` Right Suspended + Right cancelled <- Store.runStoreIO storeHandle $ cancelChild h + cancelled `shouldBe` True + Right childJournal <- + Store.runStoreIO storeHandle $ + Store.readStreamForward (StreamName "wf:ship-cancel-child") (StreamVersion 0) 10 + Right childDecoded <- pure (traverse (decodeRecorded workflowJournalCodec) (Vector.toList childJournal)) + any (\case WorkflowCancelled{} -> True; _ -> False) childDecoded `shouldBe` True + Right st <- Store.runStoreIO storeHandle $ Child.childStatus "cancel-child" "ship" + st `shouldBe` Just Child.ChildCancelled + Right parentJournal <- + Store.runStoreIO storeHandle $ + Store.readStreamForward (StreamName "wf:parent-p3") (StreamVersion 0) 10 + Right parentDecoded <- pure (traverse (decodeRecorded workflowJournalCodec) (Vector.toList parentJournal)) + [r | StepRecorded "child:cancel-child:result" r _ <- parentDecoded] + `shouldBe` [object ["cancelled" Aeson..= True]] + -- driving the child returns Cancelled and runs none of its steps. + childOutcome <- + Store.runStoreIO storeHandle $ + runWorkflow (WorkflowName "ship") childWid shipWorkflow + childOutcome `shouldBe` Right Keiro.Workflow.Cancelled + Right childJournal2 <- + Store.runStoreIO storeHandle $ + Store.readStreamForward (StreamName "wf:ship-cancel-child") (StreamVersion 0) 10 + Right childDecoded2 <- pure (traverse (decodeRecorded workflowJournalCodec) (Vector.toList childJournal2)) + any (\case StepRecorded "pack" _ _ -> True; _ -> False) childDecoded2 `shouldBe` False + -- re-invoking the parent throws WorkflowChildCancelled. + Store.runStoreIO + storeHandle + (runWorkflow (WorkflowName "parent") (WorkflowId "p3") (parentWorkflow childWid)) + `shouldThrow` (== WorkflowChildCancelled (WorkflowName "ship") childWid) + + it "repairs a cancelled child row when cancelChild is retried after the row flip" $ \storeHandle -> do + let childWid = WorkflowId "cancel-child-crash" + h = ChildHandle (WorkflowName "ship") childWid + Right Suspended <- + Store.runStoreIO storeHandle $ + runWorkflow (WorkflowName "parent") (WorkflowId "p-cancel-crash") (parentWorkflow childWid) + Right transitioned <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + Child.markChildCancelledTx "cancel-child-crash" "ship" + transitioned `shouldBe` True + Right retried <- Store.runStoreIO storeHandle $ cancelChild h + retried `shouldBe` False + Right childJournal <- + Store.runStoreIO storeHandle $ + Store.readStreamForward (StreamName "wf:ship-cancel-child-crash") (StreamVersion 0) 10 + Right childDecoded <- pure (traverse (decodeRecorded workflowJournalCodec) (Vector.toList childJournal)) + any (\case WorkflowCancelled{} -> True; _ -> False) childDecoded `shouldBe` True + Right parentJournal <- + Store.runStoreIO storeHandle $ + Store.readStreamForward (StreamName "wf:parent-p-cancel-crash") (StreamVersion 0) 10 + Right parentDecoded <- pure (traverse (decodeRecorded workflowJournalCodec) (Vector.toList parentJournal)) + [r | StepRecorded "child:cancel-child-crash:result" r _ <- parentDecoded] + `shouldBe` [object ["cancelled" Aeson..= True]] + + it "heals a cancelled-but-unmarked child from runChildWorkflow" $ \storeHandle -> do + let childWid = WorkflowId "cancel-child-drive" + Right Suspended <- + Store.runStoreIO storeHandle $ + runWorkflow (WorkflowName "parent") (WorkflowId "p-cancel-drive") (parentWorkflow childWid) + Right True <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + Child.markChildCancelledTx "cancel-child-drive" "ship" + childOutcome <- + Store.runStoreIO storeHandle $ + runChildWorkflow defaultWorkflowRunOptions (WorkflowName "ship") childWid shipWorkflow + childOutcome `shouldBe` Right Keiro.Workflow.Cancelled + Right childJournal <- + Store.runStoreIO storeHandle $ + Store.readStreamForward (StreamName "wf:ship-cancel-child-drive") (StreamVersion 0) 10 + Right childDecoded <- pure (traverse (decodeRecorded workflowJournalCodec) (Vector.toList childJournal)) + any (\case WorkflowCancelled{} -> True; _ -> False) childDecoded `shouldBe` True + Right parentJournal <- + Store.runStoreIO storeHandle $ + Store.readStreamForward (StreamName "wf:parent-p-cancel-drive") (StreamVersion 0) 10 + Right parentDecoded <- pure (traverse (decodeRecorded workflowJournalCodec) (Vector.toList parentJournal)) + [r | StepRecorded "child:cancel-child-drive:result" r _ <- parentDecoded] + `shouldBe` [object ["cancelled" Aeson..= True]] + + it "delivers an honest child result equal to the old cancellation sentinel" $ \storeHandle -> do + let childWid = WorkflowId "json-cancelled-object" + Right Suspended <- + Store.runStoreIO storeHandle $ + runWorkflow (WorkflowName "json-parent") (WorkflowId "jp1") (jsonObjectParentWorkflow childWid) + childOutcome <- + Store.runStoreIO storeHandle $ + runChildWorkflow defaultWorkflowRunOptions (WorkflowName "json-child") childWid jsonObjectChildWorkflow + childOutcome `shouldBe` Right (Completed (object ["cancelled" Aeson..= True])) + completed <- + Store.runStoreIO storeHandle $ + runWorkflow (WorkflowName "json-parent") (WorkflowId "jp1") (jsonObjectParentWorkflow childWid) + completed `shouldBe` Right (Completed (object ["cancelled" Aeson..= True])) + Right parentJournal <- + Store.runStoreIO storeHandle $ + Store.readStreamForward (StreamName "wf:json-parent-jp1") (StreamVersion 0) 10 + Right parentDecoded <- pure (traverse (decodeRecorded workflowJournalCodec) (Vector.toList parentJournal)) + [r | StepRecorded "child:json-cancelled-object:result" r _ <- parentDecoded] + `shouldBe` [object ["ok" Aeson..= object ["cancelled" Aeson..= True]]] + + it "throws WorkflowStepDecodeError when an enveloped child result has the wrong type" $ \storeHandle -> do + let childWid = WorkflowId "decode-child" + Right Suspended <- + Store.runStoreIO storeHandle $ + runWorkflow (WorkflowName "parent") (WorkflowId "p-decode") (parentWorkflow childWid) + Store.runStoreIO + storeHandle + (childCompletionHook (WorkflowName "ship") childWid (toJSON (42 :: Int))) + `shouldReturn` Right () + Store.runStoreIO + storeHandle + (runWorkflow (WorkflowName "parent") (WorkflowId "p-decode") (parentWorkflow childWid)) + `shouldThrow` \case + WorkflowStepDecodeError key _ -> key == "child:decode-child:result" + _ -> False + + it "wakes a parent with WorkflowChildFailed when a child reaches the failure ceiling" $ \storeHandle -> do + let childWid = WorkflowId "failed-child" + registry = + Map.fromList + [ (WorkflowName "parent", WorkflowDef (\_ -> parentWorkflow childWid)) + , (WorkflowName "ship", WorkflowDef (\_ -> liftIO (throwIO SimulatedCrash) *> pure ("" :: Text))) + ] + opts = defaultWorkflowResumeOptions & #maxAttempts .~ 1 + Right Suspended <- + Store.runStoreIO storeHandle $ + runWorkflow (WorkflowName "parent") (WorkflowId "p-failed-child") (parentWorkflow childWid) + Right summary <- Store.runStoreIO storeHandle $ resumeWorkflowsOnce opts registry + failed summary `shouldBe` 1 + Right (Just childRow) <- Store.runStoreIO storeHandle $ Child.lookupChild "failed-child" "ship" + childRow ^. #status `shouldBe` Child.ChildFailed + Store.runStoreIO + storeHandle + (runWorkflow (WorkflowName "parent") (WorkflowId "p-failed-child") (parentWorkflow childWid)) + `shouldThrow` \case + WorkflowChildFailed (WorkflowName "ship") (WorkflowId "failed-child") reason -> + "SimulatedCrash" `Text.isInfixOf` reason + _ -> False + + it "stops at the next step boundary when a workflow is cancelled mid-run" $ \storeHandle -> do + counter <- newIORef 0 + let name = WorkflowName "self-cancel" + wid = WorkflowId "sc1" + outcome <- + Store.runStoreIO storeHandle $ + runWorkflow name wid (selfCancellingWorkflow name wid counter) + outcome `shouldBe` Right Keiro.Workflow.Cancelled + readIORef counter `shouldReturn` 2 + Right recorded <- + Store.runStoreIO storeHandle $ + Store.readStreamForward (StreamName "wf:self-cancel-sc1") (StreamVersion 0) 10 + Right decoded <- pure (traverse (decodeRecorded workflowJournalCodec) (Vector.toList recorded)) + any (\case StepRecorded "three" _ _ -> True; _ -> False) decoded `shouldBe` False + + -- EP-42 worker-driven variant: the resume worker drives both parent and + -- child from a registry, selecting childCompletionHook for the child and + -- union-discovering the zero-step child. + it "drives a parent and its child to completion through the resume worker" $ \storeHandle -> do + let childWid = WorkflowId "ship-3" + registry = + Map.fromList + [ (WorkflowName "parent", WorkflowDef (\_ -> parentWorkflow childWid)) + , (WorkflowName "ship", WorkflowDef (\_ -> shipWorkflow)) + ] + Right Suspended <- + Store.runStoreIO storeHandle $ + runWorkflow (WorkflowName "parent") (WorkflowId "p4") (parentWorkflow childWid) + let drive = Store.runStoreIO storeHandle (resumeWorkflowsOnce defaultWorkflowResumeOptions registry) + Right _ <- drive + Right _ <- drive + Right _ <- drive + Right parentJournal <- + Store.runStoreIO storeHandle $ + Store.readStreamForward (StreamName "wf:parent-p4") (StreamVersion 0) 10 + Right parentDecoded <- pure (traverse (decodeRecorded workflowJournalCodec) (Vector.toList parentJournal)) + any (\case WorkflowCompleted{} -> True; _ -> False) parentDecoded `shouldBe` True + Right (Just childRow) <- Store.runStoreIO storeHandle $ Child.lookupChild "ship-3" "ship" + childRow ^. #status `shouldBe` Child.ChildCompleted + + it "attaches to a completed child after continueAsNew" $ \storeHandle -> do + let childWid = WorkflowId "ship-rotated" + parentName = WorkflowName "parent-rotating" + parentId = WorkflowId "p-rotating" + body = rotatingParentWorkflow childWid + Right Suspended <- Store.runStoreIO storeHandle $ runWorkflow parentName parentId body + childOutcome <- + Store.runStoreIO storeHandle $ + runChildWorkflow defaultWorkflowRunOptions (WorkflowName "ship") childWid shipWorkflow + childOutcome `shouldBe` Right (Completed "packed+labelled") + Right ContinuedAsNew <- Store.runStoreIO storeHandle $ runWorkflow parentName parentId body + repair <- Store.runStoreIO storeHandle $ runWorkflow parentName parentId body + repair `shouldBe` Right Suspended + completed <- Store.runStoreIO storeHandle $ runWorkflow parentName parentId body + completed `shouldBe` Right (Completed "packed+labelled") + + describe "Keiro.Workflow.Gc" $ around (withFreshStore fixture) $ do + it "deletes terminal workflow data after retention" $ \storeHandle -> do + let name = WorkflowName "gc-basic" + wid = WorkflowId "gb-1" + gcStreamName = workflowGenerationStreamName name wid 0 + aid = fromMaybe (error "invalid gc awakeable uuid") (fromString "00000000-0000-0000-0000-0000000000a1") + timerId = fromMaybe (error "invalid gc timer uuid") (fromString "00000000-0000-0000-0000-0000000000a2") + counter <- newIORef (0 :: Int) + Right (Completed _) <- + Store.runStoreIO storeHandle $ + runWorkflowWith + (defaultWorkflowRunOptions & #snapshotPolicy .~ OnTerminal) + name + wid + (demoWorkflow counter) + now <- getCurrentTime + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ do + Awk.registerAwakeableTx aid "gc-basic" "gb-1" + Tx.statement (timerId, "gc-basic", "gb-1", now, object ["kind" Aeson..= ("keiro.workflow.sleep" :: Text)], "fired") insertGcTimerStmt + Right beforeCounts <- Store.runStoreIO storeHandle $ workflowOwnedRowCounts "gc-basic" "gb-1" + beforeCounts `shouldBe` (1, 3, 1, 0, 1, 1) + Right freshSummary <- + Store.runStoreIO storeHandle $ + WorkflowGc.gcWorkflowsOnce + now + WorkflowGc.WorkflowGcPolicy{retention = 3600, batchSize = 10} + freshSummary `shouldBe` WorkflowGc.WorkflowGcSummary{scanned = 0, deleted = 0} + Right (Just _) <- Store.runStoreIO storeHandle $ Store.lookupStreamId gcStreamName + Right deletedSummary <- + Store.runStoreIO storeHandle $ + WorkflowGc.gcWorkflowsOnce + (addUTCTime 1 now) + WorkflowGc.WorkflowGcPolicy{retention = 0, batchSize = 10} + deletedSummary `shouldBe` WorkflowGc.WorkflowGcSummary{scanned = 1, deleted = 1} + Right Nothing <- Store.runStoreIO storeHandle $ Store.lookupStreamId gcStreamName + Right afterCounts <- Store.runStoreIO storeHandle $ workflowOwnedRowCounts "gc-basic" "gb-1" + afterCounts `shouldBe` (0, 0, 0, 0, 0, 0) + + it "keeps completed children while a parent is live and converges after partial cleanup" $ \storeHandle -> do + let parentName = WorkflowName "gc-live-parent" + parentId = WorkflowId "gp-1" + childName = WorkflowName "gc-child" + childId = WorkflowId "gc-1" + now <- getCurrentTime + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ do + Instance.upsertInstanceTx "gp-1" "gc-live-parent" 0 Instance.WfRunning Nothing + Child.registerChildTx "gc-1" "gc-child" "gp-1" "gc-live-parent" "child:gc-1:result" + void (Child.markChildResultTx "gc-1" "gc-child" (toJSON ("ok" :: Text)) now) + Right () <- + Store.runStoreIO storeHandle $ + appendJournalEntry childName childId (WorkflowCompleted now) + Right held <- + Store.runStoreIO storeHandle $ + WorkflowGc.gcWorkflowsOnce + (addUTCTime 1 now) + WorkflowGc.WorkflowGcPolicy{retention = 0, batchSize = 10} + held `shouldBe` WorkflowGc.WorkflowGcSummary{scanned = 0, deleted = 0} + Right childStillThere <- Store.runStoreIO storeHandle $ Store.lookupStreamId (workflowGenerationStreamName childName childId 0) + childStillThere `shouldSatisfy` isJust + Right () <- + Store.runStoreIO storeHandle $ + appendJournalEntry parentName parentId (WorkflowCompleted now) + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + Tx.statement ("gc-1", "gc-child") deleteGcStepsStmt + Right collected <- + Store.runStoreIO storeHandle $ + WorkflowGc.gcWorkflowsOnce + (addUTCTime 1 now) + WorkflowGc.WorkflowGcPolicy{retention = 0, batchSize = 10} + collected `shouldBe` WorkflowGc.WorkflowGcSummary{scanned = 2, deleted = 2} + Right parentGone <- Store.runStoreIO storeHandle $ Instance.lookupInstance parentName parentId + parentGone `shouldBe` Nothing + Right childGone <- Store.runStoreIO storeHandle $ Instance.lookupInstance childName childId + childGone `shouldBe` Nothing + Right childRows <- Store.runStoreIO storeHandle $ workflowOwnedChildCount "gc-child" "gc-1" + childRows `shouldBe` 0 + +{- | Increment a shared counter and return its new value (the step's side +effect, so replay can be proven by watching the counter). +-} +incrementAndRead :: IORef Int -> IO Int +incrementAndRead ref = atomicModifyIORef' ref (\n -> (n + 1, n + 1)) + +{- | Six numbered steps, each returning its index after bumping a shared +counter. The counter lets a re-hydration prove the steps short-circuit +(it stays at 6 when every step is replayed from the journal/snapshot). +-} +countingSixSteps :: (Workflow :> es, IOE :> es) => IORef Int -> Eff es [Int] +countingSixSteps counter = + mapM + (\i -> step (StepName ("s" <> Text.pack (show i))) (liftIO (incrementAndRead counter) >> pure i)) + [1 .. 6] + +newtype Approx = Approx Double + deriving stock (Eq, Show) + +instance ToJSON Approx where + toJSON (Approx d) = toJSON (round d :: Int) + +instance FromJSON Approx where + parseJSON value = do + n <- Aeson.parseJSON value + pure (Approx (fromIntegral (n :: Int))) + +data RejectingRoundTrip = RejectingRoundTrip + deriving stock (Eq, Show) + +instance ToJSON RejectingRoundTrip where + toJSON RejectingRoundTrip = Aeson.String "not-an-object" + +instance FromJSON RejectingRoundTrip where + parseJSON = Aeson.withObject "RejectingRoundTrip" $ \_ -> pure RejectingRoundTrip + +{- | A distinguished exception used to simulate a process crash mid-workflow +(after a step has committed its journal append but before completion). +-} +data SimulatedCrash = SimulatedCrash + deriving stock (Show) + +instance Exception SimulatedCrash + +{- | A three-step workflow; each step bumps a shared counter so a resume can +prove steps short-circuit (the counter only advances for steps that run). +-} +threeStep :: (Workflow :> es, IOE :> es) => IORef Int -> Eff es (Int, Int, Int) +threeStep counter = do + a <- step (StepName "s1") (liftIO (incrementAndRead counter)) + b <- step (StepName "s2") (liftIO (incrementAndRead counter)) + c <- step (StepName "s3") (liftIO (incrementAndRead counter)) + pure (a, b, c) + +threeStepThenSignal :: (Workflow :> es, IOE :> es) => IORef Int -> MVar () -> Eff es (Int, Int, Int) +threeStepThenSignal counter done = do + result <- threeStep counter + liftIO (putMVar done ()) + pure result + +{- | Runs step @"s1"@ (which commits its own journal append) then crashes, so +the journal is left with one StepRecorded and no WorkflowCompleted. +-} +crashAfterStep1 :: (Workflow :> es, IOE :> es) => IORef Int -> Eff es (Int, Int, Int) +crashAfterStep1 counter = do + _ <- step (StepName "s1") (liftIO (incrementAndRead counter)) + _ <- liftIO (throwIO SimulatedCrash) + pure (0, 0, 0) + +{- | Awaits an external step, then runs a step that bumps the counter. Used to +prove the resume worker drives a suspended workflow to completion once its +awaited step is journaled. +-} +awaitingThenStep :: (Workflow :> es, IOE :> es) => IORef Int -> Eff es Text +awaitingThenStep counter = do + decision <- awaitStep (StepName "awk:approval") (pure ()) + _ <- step (StepName "use") (liftIO (incrementAndRead counter) >> pure (decision <> "!")) + pure (decision <> "-done") + +{- | A rolling-total workflow (EP-48 continue-as-new acceptance). It adds @total@ +unit-valued work steps to a running total, rotating its journal every +@rotateEvery@ steps via 'continueAsNew'. The carried seed is the pair +@(runningTotal, stepsDoneGlobally)@ so each generation knows the global +progress; @genDone@ counts steps within the /current/ generation to bound it. +Each work step bumps @counter@ exactly once (proving rotation neither drops +nor double-counts) and returns 1, so the final total equals @total@. + +Step names are the global step index (@w0@, @w1@, …), so they are unique +within each generation's journal and replay-stable. Note the regression +direction: on a tree where 'continueAsNew' did not rotate, this body would put +all @total@ steps on generation 0's single journal and the per-generation +@<= K@ bound below would fail for @total > K@. +-} +rollingTotal :: (Workflow :> es, IOE :> es) => IORef Int -> Int -> Int -> Eff es Int +rollingTotal counter rotateEvery total = do + (acc0, done0) <- restoreSeed (0 :: Int, 0 :: Int) + go acc0 done0 0 + where + go acc done genDone + | done >= total = pure acc -- all global work done: this generation completes + | genDone >= rotateEvery = continueAsNew (acc, done) -- bound this generation; carry onward + | otherwise = do + n <- + step + (StepName ("w" <> Text.pack (show done))) + (liftIO (modifyIORef' counter (+ 1) >> pure (1 :: Int))) + go (acc + n) (done + 1) (genDone + 1) + +-- The patch id under test (EP-49). +fraudPatchId :: PatchId +fraudPatchId = PatchId "fraud-check-v2" + +{- | The workflow BEFORE the patch shipped: reserve, then await an external step +(so an instance can be left in flight, mid-journal, with one ordinary step +recorded and no completion). Used to create the in-flight instance. +-} +prePatchWorkflow :: (Workflow :> es, IOE :> es) => IORef Int -> Eff es Text +prePatchWorkflow counter = do + _ <- step (StepName "reserve-inventory") (liftIO (incrementAndRead counter) >> pure ()) + (_ :: ()) <- awaitStep (StepName "awk:gate") (pure ()) -- park here, in flight + pure "old-done" + +{- | The workflow AFTER the patch shipped: the same first step, then a +patch-gated cross-cutting branch. The in-flight instance (which already +journaled reserve-inventory under the pre-patch code) must observe False and +take the OLD branch; a fresh instance must observe True and take the NEW branch. +-} +postPatchWorkflow :: (Workflow :> es, IOE :> es) => IORef Int -> Eff es Text +postPatchWorkflow counter = do + _ <- step (StepName "reserve-inventory") (liftIO (incrementAndRead counter) >> pure ()) + useNew <- patch fraudPatchId + if useNew + then step (StepName "new-charge") (pure "new-branch") + else step (StepName "old-charge") (pure "old-branch") + +postPatchAfterSuspendWorkflow :: (Workflow :> es, IOE :> es) => IORef Int -> Eff es Text +postPatchAfterSuspendWorkflow counter = do + _ <- step (StepName "reserve-inventory") (liftIO (incrementAndRead counter) >> pure ()) + (_ :: ()) <- awaitStep (StepName "awk:gate") (pure ()) + useNew <- patch fraudPatchId + if useNew + then step (StepName "new-charge") (pure "new-branch") + else step (StepName "old-charge") (pure "old-branch") + +prePatchWakeOnlyWorkflow :: (Workflow :> es) => Eff es Text +prePatchWakeOnlyWorkflow = do + (_ :: ()) <- awaitStep (StepName "awk:gate") (pure ()) + pure "old-done" + +postPatchWakeOnlyWorkflow :: (Workflow :> es) => Eff es Text +postPatchWakeOnlyWorkflow = do + (_ :: ()) <- awaitStep (StepName "awk:gate") (pure ()) + useNew <- patch fraudPatchId + if useNew + then step (StepName "new-charge") (pure "new-branch") + else step (StepName "old-charge") (pure "old-branch") + +rotatingPatchWorkflow :: (Workflow :> es) => Eff es Text +rotatingPatchWorkflow = do + seed <- restoreSeed (0 :: Int) + if seed < 1 + then continueAsNew (seed + 1) + else do + useNew <- patch fraudPatchId + if useNew + then step (StepName "new-charge") (pure "new-branch") + else step (StepName "old-charge") (pure "old-branch") + +{- | A workflow (EP-50 push tests) that awaits an external "awk:gate" step, then +runs a step that fills @done@ — so a test can observe the exact moment the +workflow resumes to completion. Awaiting first means the journal is empty until +the external gate append, which is what makes the instance discoverable by the +resume worker (the gate's StepRecorded is the first index row). +-} +gateThenSignal :: (Workflow :> es, IOE :> es) => MVar () -> Eff es Text +gateThenSignal done = do + (_ :: ()) <- awaitStep (StepName "awk:gate") (pure ()) + _ <- step (StepName "after-gate") (liftIO (putMVar done ()) >> pure ()) + pure "resumed" + +-- | A two-step workflow whose steps each bump a shared counter. +demoWorkflow :: (Workflow :> es, IOE :> es) => IORef Int -> Eff es (Int, Int) +demoWorkflow counter = do + a <- step (StepName "first") (liftIO (incrementAndRead counter)) + b <- step (StepName "second") (liftIO (incrementAndRead counter)) + pure (a, b) + +{- | A workflow that immediately awaits a step nothing ever arms — used to +exercise the suspend path and external completion. +-} +neverArmingWorkflow :: (Workflow :> es) => Eff es Int +neverArmingWorkflow = awaitStep (StepName "awk:test") (pure ()) + +{- | The awakeable validation workflow: allocate a durable promise, suspend on +it, and (once signalled) append "!" to the payload through a recorded step. +-} +approvalFlowWithId :: (Workflow :> es, Store :> es, IOE :> es) => IORef (Maybe AwakeableId) -> Eff es Text +approvalFlowWithId ref = do + (aid, await) <- awakeableNamed (StepName "approval") + liftIO (writeIORef ref (Just aid)) + v <- await + step (StepName "use") (pure (v <> "!")) + +readRequiredAwakeableId :: IORef (Maybe AwakeableId) -> IO AwakeableId +readRequiredAwakeableId ref = + readIORef ref >>= \case + Just aid -> pure aid + Nothing -> fail "workflow did not allocate an awakeable id" + +uuidLiteral :: String -> UUID +uuidLiteral raw = + case fromString raw of + Just uuid -> uuid + Nothing -> error ("invalid UUID literal in test: " <> raw) + +{- | A two-step workflow with a durable sleep between the steps. The sleep's +name and delay are parameters so one helper drives both the zero-delta and +the real-time tests. +-} +sleepDemoNamed :: + (Workflow :> es, Store :> es, IOE :> es) => + IORef Int -> StepName -> NominalDiffTime -> Eff es (Int, Int) +sleepDemoNamed counter sName delta = do + a <- step (StepName "a") (liftIO (incrementAndRead counter)) + sleepNamed sName delta + b <- step (StepName "b") (liftIO (incrementAndRead counter)) + pure (a, b) + +rollingSleepWorkflow :: + (Workflow :> es, Store :> es, IOE :> es) => + IORef Int -> Eff es Int +rollingSleepWorkflow counter = do + seed <- restoreSeed (0 :: Int) + _ <- step (StepName "work") (liftIO (incrementAndRead counter)) + if seed < 2 + then sleepNamed (StepName "cool") 0 >> continueAsNew (seed + 1) + else pure seed + +rollingAwakeableWorkflow :: + (Workflow :> es, Store :> es, IOE :> es) => + IORef [AwakeableId] -> Eff es Text +rollingAwakeableWorkflow idsRef = do + seed <- restoreSeed (0 :: Int) + (aid, await) <- awakeableNamed (StepName "gate") + liftIO (modifyIORef' idsRef (\ids -> if aid `elem` ids then ids else ids <> [aid])) + value <- await + if seed < 1 + then continueAsNew (seed + 1) + else step (StepName "use") (pure value) + +rotatingParentWorkflow :: + (Workflow :> es, Store :> es, IOE :> es) => + WorkflowId -> Eff es Text +rotatingParentWorkflow childWid = do + seed <- restoreSeed (0 :: Int) + h <- spawnChild (WorkflowName "ship") childWid shipWorkflow + result <- awaitChild h + if seed < 1 + then continueAsNew (seed + 1) + else pure result + +{- | A workflow that records one step, then suspends on an await — so it has a +step row but no completion marker (the unfinished-discovery case). +-} +stepThenAwaitWorkflow :: (Workflow :> es, IOE :> es) => IORef Int -> Eff es Int +stepThenAwaitWorkflow counter = do + _ <- step (StepName "s1") (liftIO (incrementAndRead counter)) + awaitStep (StepName "awk:wait") (pure ()) + +-- | A two-step child workflow used in the child-workflow tests. +shipWorkflow :: (Workflow :> es) => Eff es Text +shipWorkflow = do + a <- step (StepName "pack") (pure ("packed" :: Text)) + b <- step (StepName "label") (pure (a <> "+labelled")) + pure b + +{- | A parent that spawns a @"ship"@ child (id supplied), awaits its result, and +then records a @notify@ step. Parametrised by child id so each test isolates +its own child journal. +-} +parentWorkflow :: (Workflow :> es, Store :> es, IOE :> es) => WorkflowId -> Eff es Text +parentWorkflow childWid = do + h <- spawnChild (WorkflowName "ship") childWid shipWorkflow + result <- awaitChild h + _ <- step (StepName "notify") (pure ("done:" <> result)) + pure ("done:" <> result) + +jsonObjectChildWorkflow :: Eff es Aeson.Value +jsonObjectChildWorkflow = + pure (object ["cancelled" Aeson..= True]) + +jsonObjectParentWorkflow :: (Workflow :> es, Store :> es, IOE :> es) => WorkflowId -> Eff es Aeson.Value +jsonObjectParentWorkflow childWid = do + h <- spawnChild (WorkflowName "json-child") childWid jsonObjectChildWorkflow + result <- awaitChild h + _ <- step (StepName "json-notify") (pure ()) + pure result + +selfCancellingWorkflow :: (Workflow :> es, Store :> es, IOE :> es) => WorkflowName -> WorkflowId -> IORef Int -> Eff es Int +selfCancellingWorkflow name wid counter = do + _ <- step (StepName "one") (liftIO (incrementAndRead counter)) + _ <- + step (StepName "two") $ do + now <- liftIO getCurrentTime + appendJournalEntry name wid (WorkflowCancelled now) + liftIO (incrementAndRead counter) + step (StepName "three") (liftIO (incrementAndRead counter)) + +nominalDays :: Int -> NominalDiffTime +nominalDays n = fromIntegral n * 86400 + +attrKeyText :: AttributeKey Text -> Text +attrKeyText = unkey + +attrKeyTextInt64 :: AttributeKey Int64 -> Text +attrKeyTextInt64 = unkey + +textAttr :: Attributes -> Text -> Maybe Text +textAttr attrs name = case lookupAttribute attrs name of + Just (AttributeValue (TextAttribute t)) -> Just t + _ -> Nothing + +intAttr :: Attributes -> Text -> Maybe Int64 +intAttr attrs name = case lookupAttribute attrs name of + Just (AttributeValue (IntAttribute n)) -> Just n + _ -> Nothing + +{- | A frozen snapshot of an 'ImmutableSpan'. In hs-opentelemetry 1.0 the +mutable span fields (name, attributes, status) live behind the +@spanHot :: IORef SpanHot@ field rather than directly on 'ImmutableSpan', +so the tests read that reference once after the span ends and assert on +this flat record. +-} +data CapturedSpan = CapturedSpan + { csName :: Text + , csKind :: SpanKind + , csAttributes :: Attributes + , csStatus :: SpanStatus + , csContext :: SpanContext + , csParent :: Maybe Span + } + +captureSpan :: ImmutableSpan -> IO CapturedSpan +captureSpan sp = do + hot <- readIORef (spanHot sp) + pure + CapturedSpan + { csName = hotName hot + , csKind = spanKind sp + , csAttributes = hotAttributes hot + , csStatus = hotStatus hot + , csContext = spanContext sp + , csParent = spanParent sp + } + +{- | Tiny in-process \"Kafka topic\": an MVar of consumed records plus an +incrementing offset. The publisher pushes records here; the consumer +drains the MVar. There is no real broker — the goal of the fixture is +to validate that the keiro envelope and outbox/inbox semantics +compose correctly across two isolated PostgreSQL contexts. +-} +newtype KafkaTopic = KafkaTopic (MVar (Int64, [InboxKafka.KafkaInboundRecord])) + +newKafkaTopic :: IO KafkaTopic +newKafkaTopic = KafkaTopic <$> newMVar (0, []) + +kafkaTopicAccept :: (MonadIO m) => KafkaTopic -> OutboxRow -> m () +kafkaTopicAccept (KafkaTopic ref) row = liftIO $ do + let record = OutboxKafka.outboxRowToKafkaRecord row + headersText = + [ (TE.decodeUtf8 name, TE.decodeUtf8 value) + | (name, value) <- record ^. #headers + ] + now <- getCurrentTime + modifyMVar ref $ \(nextOffset, acc) -> + let inbound = + InboxKafka.KafkaInboundRecord + { topic = record ^. #topic + , partition = 0 + , offset = nextOffset + , key = fmap TE.decodeUtf8 (record ^. #key) + , payload = record ^. #payload + , headers = headersText + , receivedAt = now + } + in pure ((nextOffset + 1, inbound : acc), ()) + +kafkaTopicPublish :: + forall es. + (IOE :> es) => + KafkaTopic -> + OutboxRow -> + Eff es PublishOutcome +kafkaTopicPublish topic row = do + kafkaTopicAccept topic row + pure PublishSucceeded + +perRow :: + (OutboxRow -> Eff es PublishOutcome) -> + [OutboxRow] -> + Eff es [(OutboxId, PublishOutcome)] +perRow publish rows = + traverse publishOne rows + where + publishOne row = do + outcome <- publish row + pure (row ^. #outboxId, outcome) + +drainKafkaTopic :: KafkaTopic -> IO [InboxKafka.KafkaInboundRecord] +drainKafkaTopic (KafkaTopic ref) = do + (_, acc) <- readMVar ref + pure (reverse acc) + +redeliverWithDifferentOffset :: + InboxKafka.KafkaInboundRecord -> + InboxKafka.KafkaInboundRecord +redeliverWithDifferentOffset record = record & #offset .~ (record ^. #offset) + 1000 + +data ConsumeResult a + = ConsumeDecodeFailed !InboxKafka.KafkaDecodeError + | ConsumePolicyUnsatisfied !InboxError + | ConsumeApplied !(InboxResult a) + deriving stock (Eq, Show) + +{- | A worker-shaped consumer: decode the Kafka record into an +IntegrationEvent and run it through the inbox. +-} +consumeAndApply :: + forall es. + (IOE :> es, Store :> es) => + InboxKafka.KafkaInboundRecord -> + (IntegrationEvent -> Tx.Transaction ()) -> + Eff es (ConsumeResult ()) +consumeAndApply record handler = + case InboxKafka.integrationEventFromKafka record of + Left err -> pure (ConsumeDecodeFailed err) + Right (event, kafkaRef) -> do + result <- + runInboxTransaction Nothing PreferIntegrationMessageId event (Just kafkaRef) handler + case result of + Left err -> pure (ConsumePolicyUnsatisfied err) + Right applied -> pure (ConsumeApplied applied) + +billingReactionHandler :: IntegrationEvent -> Tx.Transaction () +billingReactionHandler event = case decodeJsonIntegrationEvent event of + Left _ -> Tx.condemn + Right (OrderSubmittedPayload orderId quantity) -> + Tx.statement (orderId, fromIntegral quantity :: Int64) insertReceivedOrderStmt + +loggingReactionHandler :: Text -> IntegrationEvent -> Tx.Transaction () +loggingReactionHandler _ event = do + -- The cross-context test only needs the (eventType, key) pair, not + -- the decoded payload. + let key = fromMaybe "" (event ^. #key) + Tx.statement (event ^. #source, event ^. #eventType, key) appendBillingEventLogStmt + +insertReceivedOrderStmt :: Statement (Text, Int64) () +insertReceivedOrderStmt = + preparable + """ + INSERT INTO billing_received_orders (order_id, quantity) VALUES ($1, $2) + ON CONFLICT (order_id) DO NOTHING + """ + ( contrazip2 + (E.param (E.nonNullable E.text)) + (E.param (E.nonNullable E.int8)) + ) + D.noResult + +billingReceivedOrdersCountStmt :: Statement () Int +billingReceivedOrdersCountStmt = + preparable + "SELECT COUNT(*)::bigint FROM billing_received_orders" + E.noParams + (D.singleRow (fromIntegral <$> D.column (D.nonNullable D.int8))) + +appendBillingEventLogStmt :: Statement (Text, Text, Text) () +appendBillingEventLogStmt = + preparable + "INSERT INTO billing_event_log (source, event_type, order_id) VALUES ($1, $2, $3)" + ( contrazip3 + (E.param (E.nonNullable E.text)) + (E.param (E.nonNullable E.text)) + (E.param (E.nonNullable E.text)) + ) + D.noResult + +billingEventLogStmt :: Statement () [(Text, Text)] +billingEventLogStmt = + preparable + "SELECT event_type, order_id FROM billing_event_log ORDER BY seq" + E.noParams + ( D.rowList + ( (,) + <$> D.column (D.nonNullable D.text) + <*> D.column (D.nonNullable D.text) + ) + ) + +orderSubmittedEnvelope :: Text -> Int -> Text -> IntegrationEvent +orderSubmittedEnvelope orderId quantity messageId = + encodeJsonIntegrationEvent + ( sampleIntegrationEnvelope + & #messageId + .~ messageId + & #eventType + .~ "OrderSubmitted" + & #key + .~ Just orderId + ) + (OrderSubmittedPayload orderId quantity) + +orderCancelledEnvelope :: Text -> Text -> IntegrationEvent +orderCancelledEnvelope orderId messageId = + sampleIntegrationEnvelope + & #messageId + .~ messageId + & #eventType + .~ "OrderCancelled" + & #key + .~ Just orderId + & #payloadBytes + .~ ("{\"orderId\":\"" <> TE.encodeUtf8 orderId <> "\"}") + & #contentType + .~ ApplicationJson + +inboxTestCounterInsertStmt :: Statement Text () +inboxTestCounterInsertStmt = + preparable + "INSERT INTO inbox_test_counter (message_id) VALUES ($1)" + (E.param (E.nonNullable E.text)) + D.noResult + +inboxTestCounterCountStmt :: Statement () Int +inboxTestCounterCountStmt = + preparable + "SELECT COUNT(*)::bigint FROM inbox_test_counter" + E.noParams + (D.singleRow (fromIntegral <$> D.column (D.nonNullable D.int8))) + +sampleProducer :: IntegrationProducer () +sampleProducer = + IntegrationProducer + { name = "ordering-integration-producer" + , source = "ordering" + , messageIdPrefix = "msg" + , mapEvent = \_recorded () -> Just sampleDraft + } + +sampleDraft :: IntegrationEventDraft +sampleDraft = + IntegrationEventDraft + { destination = "billing.orders.v1" + , key = Just "order-123" + , eventType = "OrderSubmitted" + , schemaVersion = 1 + , contentType = ApplicationJson + , schemaReference = Nothing + , sourceEventId = Nothing + , sourceGlobalPosition = Nothing + , payloadBytes = "{\"orderId\":\"order-123\",\"quantity\":5}" + , occurredAt = UTCTime (ModifiedJulianDay 60000) (secondsToDiffTime 0) + , causationId = Nothing + , correlationId = Nothing + , traceContext = Nothing + , attributes = Just (object ["source" Aeson..= ("test-suite" :: Text)]) + } + +sampleOutboxRow :: IntegrationEvent -> OutboxRow +sampleOutboxRow event = + OutboxRow + { outboxId = OutboxId outboxUuid1 + , event + , status = OutboxPending + , attemptCount = 0 + , nextAttemptAt = UTCTime (ModifiedJulianDay 60000) (secondsToDiffTime 0) + , lastError = Nothing + , publishedAt = Nothing + , createdAt = UTCTime (ModifiedJulianDay 60000) (secondsToDiffTime 0) + , updatedAt = UTCTime (ModifiedJulianDay 60000) (secondsToDiffTime 0) + } + +backdateOutboxUpdatedAt :: (Store :> es) => OutboxId -> UTCTime -> Eff es () +backdateOutboxUpdatedAt oid timestamp = + Store.runTransaction $ + Tx.statement (unOutboxId oid, timestamp) backdateOutboxUpdatedAtStmt + +backdateOutboxUpdatedAtStmt :: Statement (UUID, UTCTime) () +backdateOutboxUpdatedAtStmt = + preparable + "UPDATE keiro.keiro_outbox SET updated_at = $2 WHERE outbox_id = $1" + ( contrazip2 + (E.param (E.nonNullable E.uuid)) + (E.param (E.nonNullable E.timestamptz)) + ) + D.noResult + +backdateOutboxPublishedAt :: (Store :> es) => OutboxId -> UTCTime -> Eff es () +backdateOutboxPublishedAt oid timestamp = + Store.runTransaction $ + Tx.statement (unOutboxId oid, timestamp) backdateOutboxPublishedAtStmt + +backdateOutboxPublishedAtStmt :: Statement (UUID, UTCTime) () +backdateOutboxPublishedAtStmt = + preparable + "UPDATE keiro.keiro_outbox SET published_at = $2 WHERE outbox_id = $1" + ( contrazip2 + (E.param (E.nonNullable E.uuid)) + (E.param (E.nonNullable E.timestamptz)) + ) + D.noResult + +outboxUuid1, outboxUuid2, outboxUuid3, outboxUuid4 :: UUID +outboxUuid1 = case fromString "018f0f18-0000-7000-8000-000000000a01" of + Just uuid -> uuid + Nothing -> error "invalid outbox uuid 1" +outboxUuid2 = case fromString "018f0f18-0000-7000-8000-000000000a02" of + Just uuid -> uuid + Nothing -> error "invalid outbox uuid 2" +outboxUuid3 = case fromString "018f0f18-0000-7000-8000-000000000a03" of + Just uuid -> uuid + Nothing -> error "invalid outbox uuid 3" +outboxUuid4 = case fromString "018f0f18-0000-7000-8000-000000000a04" of + Just uuid -> uuid + Nothing -> error "invalid outbox uuid 4" + +outboxIdFromOrdinal :: Word64 -> OutboxId +outboxIdFromOrdinal n = + OutboxId (fromWords64 0x018f0f1800007000 (0x8000000000000000 + n)) + +uniqueIds :: (Eq a) => [a] -> [a] +uniqueIds = foldr (\x xs -> if x `elem` xs then xs else x : xs) [] + +data OrderSubmittedPayload = OrderSubmittedPayload + { orderId :: !Text + , quantity :: !Int + } + deriving stock (Generic, Eq, Show) + +instance ToJSON OrderSubmittedPayload where + toJSON = genericToJSON (aesonPrefix camelCase) + toEncoding = genericToEncoding (aesonPrefix camelCase) + +instance FromJSON OrderSubmittedPayload where + parseJSON = genericParseJSON (aesonPrefix camelCase) + +sampleIntegrationEnvelope :: IntegrationEvent +sampleIntegrationEnvelope = + IntegrationEvent + { messageId = "018f0f18-17aa-7000-8000-0000000000aa" + , source = "ordering" + , destination = "billing.orders.v1" + , key = Just "order-123" + , eventType = "OrderSubmitted" + , schemaVersion = 1 + , contentType = ApplicationJson + , schemaReference = + Just + SchemaReference + { registry = Just "https://schemas.example/registry" + , subject = Just "billing.orders.v1.OrderSubmitted" + , version = Just 1 + , schemaId = Just 42 + , fingerprint = Just "sha256:abc123" + } + , sourceEventId = Just (EventId integrationSourceEventUuid) + , sourceGlobalPosition = Just (GlobalPosition 42) + , payloadBytes = "{\"orderId\":\"order-123\",\"quantity\":5}" + , occurredAt = UTCTime (ModifiedJulianDay 60000) (secondsToDiffTime 0) + , causationId = Just (EventId integrationCausationUuid) + , correlationId = Just (EventId integrationCorrelationUuid) + , traceContext = + Just + TraceContext + { traceparent = "00-0af7651916cd43dd8448eb211c80319c-b7ad6b7169203331-01" + , tracestate = Just "rojo=00f067aa0ba902b7" + } + , attributes = Nothing + } + +integrationSourceEventUuid :: UUID +integrationSourceEventUuid = + case fromString "018f0f18-17aa-7000-8000-000000000003" of + Just uuid -> uuid + Nothing -> error "invalid integration source event UUID" + +integrationCausationUuid :: UUID +integrationCausationUuid = + case fromString "018f0f18-17aa-7000-8000-000000000004" of + Just uuid -> uuid + Nothing -> error "invalid integration causation UUID" + +integrationCorrelationUuid :: UUID +integrationCorrelationUuid = + case fromString "018f0f18-17aa-7000-8000-000000000005" of + Just uuid -> uuid + Nothing -> error "invalid integration correlation UUID" + +data OrderStream + +data OrderEvent + = OrderPlaced !Text !Int + deriving stock (Generic, Eq, Show) + +data OrderState + = Idle + deriving stock (Generic, Eq, Show) + +data OrderCommand + = PlaceOrder + deriving stock (Generic, Eq, Show) + +orderCodec :: Codec OrderEvent +orderCodec = + Codec + { eventTypes = EventType "OrderPlaced" :| [] + , eventType = \case + OrderPlaced{} -> EventType "OrderPlaced" + , schemaVersion = 2 + , encode = \case + OrderPlaced orderId quantity -> + object ["orderId" Aeson..= orderId, "quantity" Aeson..= quantity] + , decode = parseOrderPlaced + , upcasters = [(1, const upcastOrderPlacedV1)] + } + +gappyCodec :: Codec OrderEvent +gappyCodec = + Codec + { eventTypes = orderCodec ^. #eventTypes + , eventType = orderCodec ^. #eventType + , schemaVersion = 4 + , encode = orderCodec ^. #encode + , decode = orderCodec ^. #decode + , upcasters = [(1, const upcastOrderPlacedV1), (3, const Right)] + } + +parseOrderPlaced :: EventType -> Value -> Either Text OrderEvent +parseOrderPlaced _ value = + case parseEither parser value of + Right event -> Right event + Left message -> Left (fromStringLiteral message) + where + parser = withObject "OrderPlaced" $ \objectValue -> + OrderPlaced + <$> objectValue .: "orderId" + <*> objectValue .: "quantity" + +upcastOrderPlacedV1 :: Value -> Either Text Value +upcastOrderPlacedV1 value = + case parseEither parser value of + Right migrated -> Right migrated + Left message -> Left (fromStringLiteral message) + where + parser = withObject "OrderPlacedV1" $ \objectValue -> do + orderId <- objectValue .: "orderId" + quantity <- objectValue .: "qty" + pure (object ["orderId" Aeson..= (orderId :: Text), "quantity" Aeson..= (quantity :: Int)]) + +metadataForOrDie :: Int -> Maybe Value -> Value +metadataForOrDie version existing = + either (error . show) id (metadataFor version existing) + +emptyTransducer :: SymTransducer () '[] OrderState OrderCommand OrderEvent +emptyTransducer = + SymTransducer + { edgesOut = \_ -> [] + , initial = Idle + , initialRegs = RNil + , isFinal = \_ -> True + } + +type CounterEventStream = EventStream (HsPred '[] CounterCommand) '[] CounterState CounterCommand CounterEvent + +type ValidatedCounterEventStream = ValidatedEventStream (HsPred '[] CounterCommand) '[] CounterState CounterCommand CounterEvent + +type SnapshotCounterRegs = '[ '("lastAmount", Int)] + +type UninitializedSnapshotRegs = '[ '("initialized", Int), '("neverWritten", Int)] + +type SnapshotCounterEventStream = EventStream (HsPred SnapshotCounterRegs CounterCommand) SnapshotCounterRegs CounterState CounterCommand CounterEvent + +type PartialSnapshotEventStream = EventStream (HsPred SnapshotCounterRegs CounterCommand) SnapshotCounterRegs PartialSnapshotState CounterCommand CounterEvent + +type ValidatedSnapshotCounterEventStream = ValidatedEventStream (HsPred SnapshotCounterRegs CounterCommand) SnapshotCounterRegs CounterState CounterCommand CounterEvent + +type UninitializedSnapshotEventStream = EventStream (HsPred UninitializedSnapshotRegs CounterCommand) UninitializedSnapshotRegs CounterState CounterCommand CounterEvent + +data CounterCommand + = Add !Int + deriving stock (Generic, Eq, Show) + +data SkipCommand + = SAdd !Int + | SSkip + deriving stock (Generic, Eq, Show) + +data CounterEvent + = CounterAdded !Int + | CounterAudited !Int + deriving stock (Generic, Eq, Show) + +data CounterState + = Counting + deriving stock (Generic, Eq, Show, Enum, Bounded, Ord) + deriving anyclass (FromJSON, ToJSON) + +data DrainState + = Draining + | Drained + deriving stock (Generic, Eq, Show, Enum, Bounded, Ord) + +data PartialSnapshotState + = SnapshotEncodable + | SnapshotEncodeBomb + deriving stock (Generic, Eq, Show, Enum, Bounded, Ord) + +instance ToJSON PartialSnapshotState where + toJSON SnapshotEncodable = Aeson.String "encodable" + toJSON SnapshotEncodeBomb = error "snapshot state encoder exploded" + +instance FromJSON PartialSnapshotState where + parseJSON = Aeson.withText "PartialSnapshotState" $ \case + "encodable" -> pure SnapshotEncodable + "bomb" -> pure SnapshotEncodeBomb + other -> fail ("unknown partial snapshot state: " <> Text.unpack other) + +counterEventStreamDef :: CounterEventStream +counterEventStreamDef = + EventStream + { transducer = counterTransducer + , initialState = Counting + , initialRegisters = RNil + , eventCodec = counterCodec + , resolveStreamName = Stream.streamName + , snapshotPolicy = Never + , stateCodec = Nothing + } + +counterEventStream :: ValidatedCounterEventStream +counterEventStream = mkEventStreamOrThrow "counter" counterEventStreamDef + +noOpCounterEventStreamDef :: CounterEventStream +noOpCounterEventStreamDef = + counterEventStreamDef & #transducer .~ noOpCounterTransducer + +noOpCounterEventStream :: ValidatedCounterEventStream +noOpCounterEventStream = mkEventStreamOrThrow "counter-no-op" noOpCounterEventStreamDef + +counterTransducer :: SymTransducer (HsPred '[] CounterCommand) '[] CounterState CounterCommand CounterEvent +counterTransducer = + SymTransducer + { edgesOut = \case + Counting -> + [ Edge + { guard = matchInCtor addCtor + , update = UKeep + , output = [pack addCtor counterAddedCtor (inpCtor addCtor #amount *: oNil)] + , target = Counting + } + ] + , initial = Counting + , initialRegs = RNil + , isFinal = \_ -> False + } + +noOpCounterTransducer :: SymTransducer (HsPred '[] CounterCommand) '[] CounterState CounterCommand CounterEvent +noOpCounterTransducer = + SymTransducer + { edgesOut = \case + Counting -> + [ Edge + { guard = matchInCtor addCtor + , update = UKeep + , output = [] + , target = Counting + } + ] + , initial = Counting + , initialRegs = RNil + , isFinal = \_ -> False + } + +multiCounterEventStreamDef :: CounterEventStream +multiCounterEventStreamDef = + counterEventStreamDef & #transducer .~ multiCounterTransducer + +multiCounterEventStream :: ValidatedCounterEventStream +multiCounterEventStream = mkEventStreamOrThrow "counter-multi" multiCounterEventStreamDef + +multiCounterTransducer :: SymTransducer (HsPred '[] CounterCommand) '[] CounterState CounterCommand CounterEvent +multiCounterTransducer = + SymTransducer + { edgesOut = \case + Counting -> + [ Edge + { guard = matchInCtor addCtor + , update = UKeep + , output = + [ pack addCtor counterAddedCtor (inpCtor addCtor #amount *: oNil) + , pack addCtor counterAuditedCtor (inpCtor addCtor #amount *: oNil) + ] + , target = Counting + } + ] + , initial = Counting + , initialRegs = RNil + , isFinal = \_ -> False + } + +{- | Both guards match at runtime but remain outside keiki's conservative pure +overlap fragment. Distinct head event constructors keep inversion unambiguous, +so this is a validated stream that exercises the runtime step witness. +-} +ambiguousCounterEventStreamDef :: CounterEventStream +ambiguousCounterEventStreamDef = + counterEventStreamDef & #transducer .~ ambiguousCounterTransducer + +ambiguousCounterEventStream :: ValidatedCounterEventStream +ambiguousCounterEventStream = + mkEventStreamOrThrow "counter-ambiguous" ambiguousCounterEventStreamDef + +ambiguousCounterTransducer :: SymTransducer (HsPred '[] CounterCommand) '[] CounterState CounterCommand CounterEvent +ambiguousCounterTransducer = + counterTransducer + { edgesOut = \case + Counting -> + [ Edge + { guard = ambiguousGuard + , update = UKeep + , output = [pack addCtor counterAddedCtor (inpCtor addCtor #amount *: oNil)] + , target = Counting + } + , Edge + { guard = ambiguousGuard + , update = UKeep + , output = [pack addCtor counterAuditedCtor (inpCtor addCtor #amount *: oNil)] + , target = Counting + } + ] + } + where + ambiguousGuard = PAnd (matchInCtor addCtor) (PNot PBot) + +snapshotCounterEventStreamDef :: SnapshotCounterEventStream +snapshotCounterEventStreamDef = + EventStream + { transducer = snapshotCounterTransducer + , initialState = Counting + , initialRegisters = RCons (Proxy @"lastAmount") 0 RNil + , eventCodec = counterCodec + , resolveStreamName = Stream.streamName + , snapshotPolicy = Every 2 + , stateCodec = Just (defaultStateCodec @SnapshotCounterRegs @CounterState 1) + } + +partialSnapshotEventStream :: ValidatedEventStream (HsPred SnapshotCounterRegs CounterCommand) SnapshotCounterRegs PartialSnapshotState CounterCommand CounterEvent +partialSnapshotEventStream = mkEventStreamOrThrow "partial-snapshot" partialSnapshotEventStreamDef + +partialSnapshotEventStreamDef :: PartialSnapshotEventStream +partialSnapshotEventStreamDef = + EventStream + { transducer = + SymTransducer + { edgesOut = \_ -> + [ Edge + { guard = matchInCtor addCtor + , update = + USet + (#lastAmount :: IndexN "lastAmount" SnapshotCounterRegs Int) + (inpCtor addCtor #amount) + , output = [pack addCtor counterAddedCtor (inpCtor addCtor #amount *: oNil)] + , target = SnapshotEncodeBomb + } + ] + , initial = SnapshotEncodable + , initialRegs = RCons (Proxy @"lastAmount") 0 RNil + , isFinal = \_ -> False + } + , initialState = SnapshotEncodable + , initialRegisters = RCons (Proxy @"lastAmount") 0 RNil + , eventCodec = counterCodec + , resolveStreamName = Stream.streamName + , snapshotPolicy = Every 1 + , stateCodec = Just (defaultStateCodec @SnapshotCounterRegs @PartialSnapshotState 1) + } + +uninitializedSnapshotEventStreamDef :: UninitializedSnapshotEventStream +uninitializedSnapshotEventStreamDef = + initializedSnapshotEventStreamDef + & #initialRegisters + .~ RCons (Proxy @"initialized") 0 (emptyRegFile @'[ '("neverWritten", Int)]) + +initializedSnapshotEventStreamDef :: UninitializedSnapshotEventStream +initializedSnapshotEventStreamDef = + EventStream + { transducer = + SymTransducer + { edgesOut = \case Counting -> [] + , initial = Counting + , initialRegs = RCons (Proxy @"initialized") 0 (RCons (Proxy @"neverWritten") 0 RNil) + , isFinal = \_ -> False + } + , initialState = Counting + , initialRegisters = RCons (Proxy @"initialized") 0 (RCons (Proxy @"neverWritten") 0 RNil) + , eventCodec = counterCodec + , resolveStreamName = Stream.streamName + , snapshotPolicy = Every 2 + , stateCodec = Just (defaultStateCodec @UninitializedSnapshotRegs @CounterState 1) + } + +snapshotCounterEventStream :: ValidatedSnapshotCounterEventStream +snapshotCounterEventStream = mkEventStreamOrThrow "snapshot-counter" snapshotCounterEventStreamDef + +snapshotCounterTransducer :: SymTransducer (HsPred SnapshotCounterRegs CounterCommand) SnapshotCounterRegs CounterState CounterCommand CounterEvent +snapshotCounterTransducer = + SymTransducer + { edgesOut = \case + Counting -> + [ Edge + { guard = matchInCtor addCtor + , update = + USet + (#lastAmount :: IndexN "lastAmount" SnapshotCounterRegs Int) + (inpCtor addCtor #amount) + , output = [pack addCtor counterAddedCtor (inpCtor addCtor #amount *: oNil)] + , target = Counting + } + ] + , initial = Counting + , initialRegs = RCons (Proxy @"lastAmount") 0 RNil + , isFinal = \_ -> False + } + +multiSnapshotCounterEventStreamDef :: SnapshotCounterEventStream +multiSnapshotCounterEventStreamDef = + snapshotCounterEventStreamDef + & #transducer + .~ multiSnapshotCounterTransducer + & #snapshotPolicy + .~ Every 1 + +multiSnapshotCounterEventStream :: ValidatedSnapshotCounterEventStream +multiSnapshotCounterEventStream = mkEventStreamOrThrow "snapshot-counter-multi" multiSnapshotCounterEventStreamDef + +multiSnapshotCounterTransducer :: SymTransducer (HsPred SnapshotCounterRegs CounterCommand) SnapshotCounterRegs CounterState CounterCommand CounterEvent +multiSnapshotCounterTransducer = + SymTransducer + { edgesOut = \case + Counting -> + [ Edge + { guard = matchInCtor addCtor + , update = + USet + (#lastAmount :: IndexN "lastAmount" SnapshotCounterRegs Int) + (inpCtor addCtor #amount) + , output = + [ pack addCtor counterAddedCtor (inpCtor addCtor #amount *: oNil) + , pack addCtor counterAuditedCtor (inpCtor addCtor #amount *: oNil) + ] + , target = Counting + } + ] + , initial = Counting + , initialRegs = RCons (Proxy @"lastAmount") 0 RNil + , isFinal = \_ -> False + } + +guardedSnapshotCounterEventStreamDef :: SnapshotCounterEventStream +guardedSnapshotCounterEventStreamDef = + snapshotCounterEventStreamDef & #transducer .~ guardedSnapshotCounterTransducer + +guardedSnapshotCounterEventStream :: ValidatedSnapshotCounterEventStream +guardedSnapshotCounterEventStream = mkEventStreamOrThrow "snapshot-counter-guarded" guardedSnapshotCounterEventStreamDef + +guardedSnapshotCounterTransducer :: SymTransducer (HsPred SnapshotCounterRegs CounterCommand) SnapshotCounterRegs CounterState CounterCommand CounterEvent +guardedSnapshotCounterTransducer = + SymTransducer + { edgesOut = \case + Counting -> + [ Edge + { guard = + PAnd + (matchInCtor addCtor) + (inpCtor addCtor #amount .== proj (#lastAmount :: Keiki.Index SnapshotCounterRegs Int)) + , update = + USet + (#lastAmount :: IndexN "lastAmount" SnapshotCounterRegs Int) + (inpCtor addCtor #amount) + , output = [pack addCtor counterAddedCtor (inpCtor addCtor #amount *: oNil)] + , target = Counting + } + ] + , initial = Counting + , initialRegs = RCons (Proxy @"lastAmount") 0 RNil + , isFinal = \_ -> False + } + +{- | A deliberately replay-unsafe stream: its single edge is an ε-edge +(empty @output@) whose @update@ reads the command's @amount@. Because +the edge emits no event, that command field cannot be recovered on +replay, so keiki's hidden-input check flags it. Used to prove +'validateEventStream' / 'mkEventStream' reject an unsafe stream. +-} +brokenHiddenInputEventStream :: SnapshotCounterEventStream +brokenHiddenInputEventStream = + snapshotCounterEventStreamDef & #transducer .~ brokenHiddenInputTransducer + +brokenHiddenInputTransducer :: SymTransducer (HsPred SnapshotCounterRegs CounterCommand) SnapshotCounterRegs CounterState CounterCommand CounterEvent +brokenHiddenInputTransducer = + SymTransducer + { edgesOut = \case + Counting -> + [ Edge + { guard = matchInCtor addCtor + , update = + USet + (#lastAmount :: IndexN "lastAmount" SnapshotCounterRegs Int) + (inpCtor addCtor #amount) + , output = [] + , target = Counting + } + ] + , initial = Counting + , initialRegs = RCons (Proxy @"lastAmount") 0 RNil + , isFinal = \_ -> False + } + +{- | A multi-event edge whose tail carries the command field omitted from its +head. The union of the outputs covers @amount@, but replay commits to an edge +by inverting only the head, so the stored chain cannot reconstruct @Add@. +-} +headUnrecoverableEventStreamDef :: CounterEventStream +headUnrecoverableEventStreamDef = + counterEventStreamDef & #transducer .~ headUnrecoverableTransducer + +headUnrecoverableEventStream :: ValidatedCounterEventStream +headUnrecoverableEventStream = mkEventStreamUnchecked headUnrecoverableEventStreamDef + +headUnrecoverableTransducer :: SymTransducer (HsPred '[] CounterCommand) '[] CounterState CounterCommand CounterEvent +headUnrecoverableTransducer = + counterTransducer + { edgesOut = \case + Counting -> + [ Edge + { guard = matchInCtor addCtor + , update = UKeep + , output = + [ pack addCtor counterAddedCtor (Keiki.lit 0 *: oNil) + , pack addCtor counterAuditedCtor (inpCtor addCtor #amount *: oNil) + ] + , target = Counting + } + ] + } + +{- | Two edges share a head wire constructor, so one stored event can invert +through both. The double-negated guard is true at runtime but deliberately +outside keiki's pure overlap fragment, isolating the inversion warning from +the separate conservative determinism check. +-} +inversionAmbiguousEventStreamDef :: CounterEventStream +inversionAmbiguousEventStreamDef = + counterEventStreamDef & #transducer .~ inversionAmbiguousTransducer + +inversionAmbiguousEventStream :: ValidatedCounterEventStream +inversionAmbiguousEventStream = + case mkEventStreamWith + Keiki.defaultValidationOptions{Keiki.checkInversionAmbiguity = False} + "counter-inversion-ambiguous" + inversionAmbiguousEventStreamDef of + Right validated -> validated + Left warnings -> error ("expected inversion-ambiguity override to validate: " <> show warnings) + +inversionAmbiguousTransducer :: SymTransducer (HsPred '[] CounterCommand) '[] CounterState CounterCommand CounterEvent +inversionAmbiguousTransducer = + counterTransducer + { edgesOut = \case + Counting -> + [ ambiguousEdge + , ambiguousEdge + ] + } + where + ambiguousEdge = + Edge + { guard = PAnd (matchInCtor addCtor) (PNot PBot) + , update = UKeep + , output = [pack addCtor counterAddedCtor (inpCtor addCtor #amount *: oNil)] + , target = Counting + } + +{- | This edge reads @Add.amount@ while guarded only by @PTop@. A different +command constructor would reach the partial projection and crash instead of +being rejected. +-} +unguardedInputReadEventStreamDef :: CounterEventStream +unguardedInputReadEventStreamDef = + counterEventStreamDef & #transducer .~ unguardedInputReadTransducer + +unguardedInputReadTransducer :: SymTransducer (HsPred '[] CounterCommand) '[] CounterState CounterCommand CounterEvent +unguardedInputReadTransducer = + counterTransducer + { edgesOut = \case + Counting -> + [ Edge + { guard = PTop + , update = UKeep + , output = [pack addCtor counterAddedCtor (inpCtor addCtor #amount *: oNil)] + , target = Counting + } + ] + } + +{- | A silent self-loop that writes a register. With no emitted event the +write cannot be reconstructed from the durable log. +-} +stateChangingEpsilonEventStreamDef :: SnapshotCounterEventStream +stateChangingEpsilonEventStreamDef = + snapshotCounterEventStreamDef & #transducer .~ stateChangingEpsilonTransducer + +stateChangingEpsilonTransducer :: SymTransducer (HsPred SnapshotCounterRegs CounterCommand) SnapshotCounterRegs CounterState CounterCommand CounterEvent +stateChangingEpsilonTransducer = + snapshotCounterTransducer + { edgesOut = \case + Counting -> + [ Edge + { guard = matchInCtor addCtor + , update = + USet + (#lastAmount :: IndexN "lastAmount" SnapshotCounterRegs Int) + (Keiki.lit 0) + , output = [] + , target = Counting + } + ] + } + +type SilentMoveEventStream = EventStream (HsPred '[] CounterCommand) '[] DrainState CounterCommand CounterEvent + +silentMoveEventStreamDef :: SilentMoveEventStream +silentMoveEventStreamDef = + EventStream + { transducer = silentMoveTransducer + , initialState = Draining + , initialRegisters = RNil + , eventCodec = counterCodec + , resolveStreamName = Stream.streamName + , snapshotPolicy = Never + , stateCodec = Nothing + } + +silentMoveTransducer :: SymTransducer (HsPred '[] CounterCommand) '[] DrainState CounterCommand CounterEvent +silentMoveTransducer = + SymTransducer + { edgesOut = \case + Draining -> + [ Edge + { guard = matchInCtor addCtor + , update = UKeep + , output = [] + , target = Drained + } + ] + Drained -> [] + , initial = Draining + , initialRegs = RNil + , isFinal = (== Drained) + } + +isStateChangingEpsilon :: Keiki.TransducerValidationWarning s -> Bool +isStateChangingEpsilon = \case + Keiki.StateChangingEpsilon{} -> True + _ -> False + +expectValidationWarning :: + (Bounded s, Enum s, Ord s, Show s) => + Text -> + Text -> + EventStream (HsPred rs ci) rs s ci co -> + Expectation +expectValidationWarning label prefix eventStream = + case mkEventStream label eventStream of + Left warnings -> do + map eswStreamLabel warnings `shouldSatisfy` all (== label) + map eswReason warnings `shouldSatisfy` any (Text.isInfixOf prefix) + Right _ -> + expectationFailure + ( "expected mkEventStream to reject " + <> Text.unpack label + <> " with warning prefix " + <> Text.unpack prefix + ) + +type AddFields = '[ '("amount", Int)] + +type SkipEventStream = EventStream (HsPred '[] SkipCommand) '[] CounterState SkipCommand CounterEvent + +type ValidatedSkipEventStream = ValidatedEventStream (HsPred '[] SkipCommand) '[] CounterState SkipCommand CounterEvent + +skipEventStream :: ValidatedSkipEventStream +skipEventStream = mkEventStreamOrThrow "skip-command" skipEventStreamDef + +skipEventStreamDef :: SkipEventStream +skipEventStreamDef = + EventStream + { transducer = skipTransducer + , initialState = Counting + , initialRegisters = RNil + , eventCodec = counterCodec + , resolveStreamName = Stream.streamName + , snapshotPolicy = Never + , stateCodec = Nothing + } + +skipTransducer :: SymTransducer (HsPred '[] SkipCommand) '[] CounterState SkipCommand CounterEvent +skipTransducer = + SymTransducer + { edgesOut = \case + Counting -> + [ Edge + { guard = matchInCtor sAddCtor + , update = UKeep + , output = [pack sAddCtor counterAddedCtor (inpCtor sAddCtor #amount *: oNil)] + , target = Counting + } + , Edge + { guard = matchInCtor sSkipCtor + , update = UKeep + , output = [] + , target = Counting + } + ] + , initial = Counting + , initialRegs = RNil + , isFinal = \_ -> False + } + +sAddCtor :: InCtor SkipCommand AddFields +sAddCtor = + InCtor + { icName = "SAdd" + , icMatch = \case + SAdd amount -> Just (RCons Proxy amount RNil) + SSkip -> Nothing + , icBuild = \case + RCons _ amount RNil -> SAdd amount + } + +sSkipCtor :: InCtor SkipCommand '[] +sSkipCtor = + InCtor + { icName = "SSkip" + , icMatch = \case + SAdd{} -> Nothing + SSkip -> Just RNil + , icBuild = \case + RNil -> SSkip + } + +addCtor :: InCtor CounterCommand AddFields +addCtor = + InCtor + { icName = "Add" + , icMatch = \case + Add amount -> Just (RCons Proxy amount RNil) + , icBuild = \case + RCons _ amount RNil -> Add amount + } + +counterAddedCtor :: WireCtor CounterEvent (Int, ()) +counterAddedCtor = + WireCtor + { wcName = "CounterAdded" + , wcMatch = \case + CounterAdded amount -> Just (amount, ()) + CounterAudited{} -> Nothing + , wcBuild = \case + (amount, ()) -> CounterAdded amount + } + +counterAuditedCtor :: WireCtor CounterEvent (Int, ()) +counterAuditedCtor = + WireCtor + { wcName = "CounterAudited" + , wcMatch = \case + CounterAudited amount -> Just (amount, ()) + CounterAdded{} -> Nothing + , wcBuild = \case + (amount, ()) -> CounterAudited amount + } + +counterCodec :: Codec CounterEvent +counterCodec = + Codec + { eventTypes = EventType "CounterAdded" :| [EventType "CounterAudited"] + , eventType = \case + CounterAdded{} -> EventType "CounterAdded" + CounterAudited{} -> EventType "CounterAudited" + , schemaVersion = 1 + , encode = \case + CounterAdded amount -> object ["amount" Aeson..= amount] + CounterAudited amount -> object ["amount" Aeson..= amount, "audited" Aeson..= True] + , decode = parseCounterEvent + , upcasters = [] + } + +parseCounterEvent :: EventType -> Value -> Either Text CounterEvent +parseCounterEvent (EventType tag) value = + case parseEither parser value of + Right event -> Right event + Left message -> Left (fromStringLiteral message) + where + parser = withObject "CounterEvent" $ \objectValue -> do + amount <- objectValue .: "amount" + case tag of + "CounterAdded" -> pure (CounterAdded amount) + "CounterAudited" -> pure (CounterAudited amount) + _ -> fail "unknown counter event type" + +counterProcessManager :: + ProcessManager + CounterEvent + (HsPred '[] CounterCommand) + '[] + CounterState + CounterCommand + CounterEvent + (HsPred '[] CounterCommand) + '[] + CounterState + CounterCommand + CounterEvent +counterProcessManager = + ProcessManager + { name = "counter-pm" + , correlate = \_ -> "order-1" + , eventStream = counterEventStream + , streamFor = \correlationId -> stream ("pm:counter-" <> correlationId) + , targetEventStream = counterEventStream + , targetProjections = const [] + , handle = \case + CounterAdded amount -> + ProcessManagerAction + { command = Add amount + , commands = + [ PMCommand + { target = stream "counter-target-order-1" + , command = Add amount + } + ] + , timers = [counterTimerRequest] + } + CounterAudited amount -> + ProcessManagerAction + { command = Add amount + , commands = [] + , timers = [] + } + } + +timerOnlyProcessManager :: + ProcessManager + CounterEvent + (HsPred '[] CounterCommand) + '[] + CounterState + CounterCommand + CounterEvent + (HsPred '[] CounterCommand) + '[] + CounterState + CounterCommand + CounterEvent +timerOnlyProcessManager = + ProcessManager + { name = "timer-only-pm" + , correlate = \_ -> "order-1" + , eventStream = noOpCounterEventStream + , streamFor = \correlationId -> stream ("pm:timer-only-" <> correlationId) + , targetEventStream = counterEventStream + , targetProjections = const [] + , handle = \case + CounterAdded amount -> + ProcessManagerAction + { command = Add amount + , commands = [] + , timers = + [ counterTimerRequest + & #processManagerName + .~ "timer-only-pm" + ] + } + CounterAudited amount -> + ProcessManagerAction + { command = Add amount + , commands = [] + , timers = [] + } + } + +-- A process manager whose OWN state stream snapshots under Every 2. +-- This is the first PM fixture to exercise a state-stream snapshot: the only +-- difference from counterProcessManager is that its eventStream carries a +-- snapshotPolicy + stateCodec (it reuses snapshotCounterEventStream), so +-- runProcessManagerOnce's manager-state append (which goes through +-- runCommandWithSql) writes and reuses snapshots. The manager registers are +-- SnapshotCounterRegs because the eventStream is a SnapshotCounterEventStream; +-- the target side stays '[]/counterEventStream exactly as counterProcessManager. +pmSnapshotCounterEventStreamDef :: SnapshotCounterEventStream +pmSnapshotCounterEventStreamDef = snapshotCounterEventStreamDef + +pmSnapshotCounterEventStream :: ValidatedSnapshotCounterEventStream +pmSnapshotCounterEventStream = mkEventStreamOrThrow "pm-snapshot-counter" pmSnapshotCounterEventStreamDef + +pmSnapshotProcessManager :: + ProcessManager + CounterEvent + (HsPred SnapshotCounterRegs CounterCommand) + SnapshotCounterRegs + CounterState + CounterCommand + CounterEvent + (HsPred '[] CounterCommand) + '[] + CounterState + CounterCommand + CounterEvent +pmSnapshotProcessManager = + ProcessManager + { name = "counter-snap-pm" + , correlate = \_ -> "order-1" + , eventStream = pmSnapshotCounterEventStream + , streamFor = \correlationId -> stream ("pm:counter-snap-" <> correlationId) + , targetEventStream = counterEventStream + , targetProjections = const [] + , handle = \case + CounterAdded amount -> + ProcessManagerAction + { command = Add amount + , commands = [] -- keep the test focused on the manager state stream + , timers = [] + } + CounterAudited amount -> + ProcessManagerAction + { command = Add amount + , commands = [] + , timers = [] + } + } + +workflowProcessManager :: + Text -> + Text -> + Text -> + ProcessManager + CounterEvent + (HsPred '[] CounterCommand) + '[] + CounterState + CounterCommand + CounterEvent + (HsPred '[] CounterCommand) + '[] + CounterState + CounterCommand + CounterEvent +workflowProcessManager managerName managerCategory targetStreamName = + counterProcessManager + { name = managerName + , streamFor = \correlationId -> stream (managerCategory <> "-" <> correlationId) + , handle = \case + CounterAdded amount -> + ProcessManagerAction + { command = Add amount + , commands = + [ PMCommand + { target = stream targetStreamName + , command = Add amount + } + ] + , timers = [] + } + CounterAudited amount -> + ProcessManagerAction + { command = Add amount + , commands = [] + , timers = [] + } + } + +assertWorkflowProcessManagerAppended :: + Either + Store.StoreError + ( Either + CommandError + (ProcessManagerResult CounterEventStream CounterEventStream) + ) -> + Expectation +assertWorkflowProcessManagerAppended = \case + Right (Right pmResult) -> do + pmResult ^. #managerResult `shouldSatisfy` \case + PMStateAppended{} -> True + _ -> False + pmResult ^. #commandResults `shouldSatisfy` \case + [PMCommandAppended{}] -> True + _ -> False + other -> expectationFailure ("expected workflow process-manager success, got " <> show other) + +counterTimerRequest :: TimerRequest +counterTimerRequest = + TimerRequest + { timerId = TimerId sampleUuid + , processManagerName = "counter-pm" + , correlationId = "order-1" + , fireAt = dueTimerTime + , payload = object ["kind" Aeson..= ("counter-timeout" :: Text)] + } + +dueTimerTime :: UTCTime +dueTimerTime = UTCTime (ModifiedJulianDay 1) (secondsToDiffTime 0) + +timerStatusAndErrorStmt :: Statement UUID (Maybe (Text, Maybe Text)) +timerStatusAndErrorStmt = + preparable + """ + SELECT status, last_error + FROM keiro.keiro_timers + WHERE timer_id = $1 + """ + (E.param (E.nonNullable E.uuid)) + (D.rowMaybe ((,) <$> D.column (D.nonNullable D.text) <*> D.column (D.nullable D.text))) + +-- | Read a timer's status and JSON payload by id (for the workflow-sleep tests). +sleepTimerStatusStmt :: Statement UUID (Maybe (Text, Value)) +sleepTimerStatusStmt = + preparable + """ + SELECT status, payload + FROM keiro.keiro_timers + WHERE timer_id = $1 + """ + (E.param (E.nonNullable E.uuid)) + (D.rowMaybe ((,) <$> D.column (D.nonNullable D.text) <*> D.column (D.nonNullable D.jsonb))) + +-- | Read a timer's fire time by id (for workflow-sleep re-arm tests). +sleepTimerFireAtStmt :: Statement UUID (Maybe UTCTime) +sleepTimerFireAtStmt = + preparable + """ + SELECT fire_at + FROM keiro.keiro_timers + WHERE timer_id = $1 + """ + (E.param (E.nonNullable E.uuid)) + (D.rowMaybe (D.column (D.nonNullable D.timestamptz))) + +recordedFrom :: EventData -> RecordedEvent +recordedFrom event = + RecordedEvent + { eventId = EventId sampleUuid + , eventType = event ^. #eventType + , streamVersion = StreamVersion 1 + , globalPosition = GlobalPosition 1 + , originalStreamId = StreamId 1 + , originalVersion = StreamVersion 1 + , payload = event ^. #payload + , metadata = event ^. #metadata + , causationId = Nothing + , correlationId = Nothing + , createdAt = UTCTime (ModifiedJulianDay 0) (secondsToDiffTime 0) + } + +recordedFromEventId :: EventId -> CounterEvent -> RecordedEvent +recordedFromEventId eventId event = + case encodeForAppend counterCodec event of + Right encoded -> recordedFrom encoded & #eventId .~ eventId + Left err -> error ("test fixture failed to encode counter event: " <> show err) + +appendCounterEventWithId :: Store.KirokuStore -> StreamName -> EventId -> CounterEvent -> IO () +appendCounterEventWithId storeHandle streamName eventId event = do + encoded <- shouldBeRight (encodeForAppend counterCodec event) + outcome <- + Store.runStoreIO storeHandle $ + Store.appendToStream streamName NoStream [encoded & #eventId ?~ eventId] + case outcome of + Right _ -> pure () + Left err -> expectationFailure ("failed to insert concurrent duplicate event: " <> show err) + +appendCounterEvents :: Store.KirokuStore -> StreamName -> [CounterEvent] -> IO () +appendCounterEvents storeHandle destinationStreamName events = do + encoded <- traverse (shouldBeRight . encodeForAppend counterCodec) events + outcome <- + Store.runStoreIO storeHandle $ + Store.appendToStream destinationStreamName NoStream encoded + case outcome of + Right _ -> pure () + Left err -> expectationFailure ("failed to insert counter events: " <> show err) + +-- Insert a real source event and drive Kiroku's acknowledgement bridge to park +-- it in kiroku.dead_letters. A second event lets the test observe that the +-- checkpoint advanced after the dead letter before stopping the subscription. +deadLetterCounterSource :: Store.KirokuStore -> SubscriptionName -> CounterEvent -> IO RecordedEvent +deadLetterCounterSource storeHandle subName sourceEvent = do + appendCounterEvents + storeHandle + (StreamName "counter-replay-source") + [sourceEvent, CounterAdded 0] + let subConfig = + ( KirokuSub.defaultSubscriptionConfig + subName + AllStreams + (\_ -> pure KirokuSub.Continue) + ) + { KirokuSub.retryPolicy = KirokuSub.RetryPolicy 1 + } + pull label source = do + result <- timeout 5_000_000 (Streamly.uncons source) + case result of + Just (Just itemAndRest) -> pure itemAndRest + Just Nothing -> fail (label <> ": subscription ended early") + Nothing -> fail (label <> ": timed out waiting for delivery") + (stream0, cancelStream) <- subscriptionAckStream storeHandle subConfig 4 + ( do + (first, stream1) <- pull "source delivery" stream0 + atomically $ + putTMVar + (ackReply first) + (KirokuSub.Retry (KirokuSub.RetryDelay 0)) + (next, stream2) <- pull "event after source dead letter" stream1 + ackEvent next ^. #eventId `shouldNotBe` ackEvent first ^. #eventId + atomically (putTMVar (ackReply next) KirokuSub.Stop) + ended <- timeout 5_000_000 (Streamly.uncons stream2) + case ended of + Just Nothing -> pure () + Just (Just _) -> expectationFailure "replay fixture delivered after Stop" + Nothing -> expectationFailure "replay fixture did not stop" + pure (ackEvent first) + ) + `finally` cancelStream + +classifyProcessManagerReplay :: ProcessManagerResult managerTarget commandTarget -> ReplayResult +classifyProcessManagerReplay result = + case result ^. #managerResult of + PMStateDuplicate{} + | Prelude.all commandIsDuplicate (result ^. #commandResults) -> ReplayedDuplicate + _ -> ReplayedFresh + where + commandIsDuplicate = \case + PMCommandDuplicate{} -> True + _ -> False + +processManagerReplayCounts :: Store.KirokuStore -> IO (Int, Int) +processManagerReplayCounts storeHandle = do + Right managerEvents <- + Store.runStoreIO storeHandle $ + Store.readStreamForward (StreamName "pm:counter-order-1") (StreamVersion 0) 10 + Right targetEvents <- + Store.runStoreIO storeHandle $ + Store.readStreamForward (StreamName "counter-target-order-1") (StreamVersion 0) 10 + pure (Vector.length managerEvents, Vector.length targetEvents) + +sampleUuid :: UUID +sampleUuid = + case fromString "018f0f18-17aa-7000-8000-000000000001" of + Just uuid -> uuid + Nothing -> error "invalid test UUID" + +sampleUuid2 :: UUID +sampleUuid2 = + case fromString "018f0f18-17aa-7000-8000-000000000002" of + Just uuid -> uuid + Nothing -> error "invalid test UUID" + +sampleUuid3 :: UUID +sampleUuid3 = + case fromString "018f0f18-17aa-7000-8000-000000000003" of + Just uuid -> uuid + Nothing -> error "invalid test UUID" + +shouldBeRight :: (HasCallStack, Show e) => Either e a -> IO a +shouldBeRight = \case + Right value -> pure value + Left err -> expectationFailure ("expected Right, got Left " <> show err) *> error "unreachable" + +shouldBeRight_ :: (HasCallStack, Show e) => Either e a -> Expectation +shouldBeRight_ = \case + Right _ -> pure () + Left err -> expectationFailure ("expected Right, got Left " <> show err) + +shouldBeLeft :: (HasCallStack, Eq e, Show e) => Either e a -> e -> Expectation +shouldBeLeft actual expected = + case actual of + Left err -> err `shouldBe` expected + Right _ -> expectationFailure ("expected Left " <> show expected <> ", got Right") + +fromStringLiteral :: String -> Text +fromStringLiteral = Text.pack + +snapshotVersionForStreamStmt :: Statement Text (Maybe StreamVersion) +snapshotVersionForStreamStmt = + preparable + """ + SELECT ks.stream_version + FROM keiro.keiro_snapshots ks + JOIN streams s ON s.stream_id = ks.stream_id + WHERE s.stream_name = $1 + """ + (E.param (E.nonNullable E.text)) + (D.rowMaybe (StreamVersion <$> D.column (D.nonNullable D.int8))) + +corruptSnapshotStateStmt :: Statement (Text, Value) () +corruptSnapshotStateStmt = + preparable + """ + UPDATE keiro.keiro_snapshots ks + SET state = $2 + FROM streams s + WHERE s.stream_id = ks.stream_id + AND s.stream_name = $1 + """ + ( contrazip2 + (E.param (E.nonNullable E.text)) + (E.param (E.nonNullable E.jsonb)) + ) + D.noResult + +corruptSnapshotShapeStmt :: Statement (Text, Text) () +corruptSnapshotShapeStmt = + preparable + """ + UPDATE keiro.keiro_snapshots ks + SET regfile_shape_hash = $2 + FROM streams s + WHERE s.stream_id = ks.stream_id + AND s.stream_name = $1 + """ + ( contrazip2 + (E.param (E.nonNullable E.text)) + (E.param (E.nonNullable E.text)) + ) + D.noResult + +counterReadModel :: ReadModel Text Int +counterReadModel = + ReadModel + { name = "counter-read-model" + , tableName = "counter_read_model" + , schema = "kiroku" + , subscriptionName = "counter-read-model-sub" + , version = 1 + , shapeHash = "counter-read-model-v1" + , defaultConsistency = Eventual + , strongScope = EntireLog + , query = \modelId -> Tx.statement modelId selectCounterReadModelStmt + } + +counterCategoryReadModel :: ReadModel Text Int +counterCategoryReadModel = + counterReadModel & #strongScope .~ CategoryHead "counter" + +registerReadModelDefinition :: (Store :> es) => ReadModel q r -> Eff es () +registerReadModelDefinition readModel = + void $ + registerReadModel + (readModel ^. #name) + (readModel ^. #version) + (readModel ^. #shapeHash) + +initializeRegisteredReadModel :: + (Store :> es) => + ReadModel q r -> + Tx.Transaction () -> + Eff es () +initializeRegisteredReadModel readModel initializeTable = do + Store.runTransaction initializeTable + registerReadModelDefinition readModel + +counterInlineProjection :: InlineProjection CounterEvent +counterInlineProjection = + InlineProjection + { name = "counter-inline-projection" + , apply = \event recorded -> + case event of + CounterAdded amount -> + Tx.statement + ( "inline" + , Prelude.fromIntegral amount + , globalPositionToInt (recorded ^. #globalPosition) + , Just (eventIdToUuid (recorded ^. #eventId)) + , metadataActor recorded + ) + upsertCounterReadModelStmt + CounterAudited{} -> pure () + } + +counterAsyncProjection :: AsyncProjection +counterAsyncProjection = + AsyncProjection + { name = "counter-async-projection" + , readModelName = "counter-read-model" + , subscriptionName = "counter-read-model-sub" + , applyRecorded = \recorded -> + case decodeRecorded counterCodec recorded of + Right (CounterAdded amount) -> + Tx.statement + ( "async-idempotent" + , Prelude.fromIntegral amount + , globalPositionToInt (recorded ^. #globalPosition) + , Just (eventIdToUuid (recorded ^. #eventId)) + , Nothing + ) + upsertCounterReadModelStmt + Right CounterAudited{} -> pure () + Left _ -> pure () + , idempotencyKey = \recorded -> recorded ^. #eventId + } + +fastWaitOptions :: PositionWaitOptions +fastWaitOptions = + PositionWaitOptions + { target = Nothing + , timeoutMicros = 50000 + , pollMicros = 5000 + } + +initializeCounterReadModelTable :: Tx.Transaction () +initializeCounterReadModelTable = + Tx.sql + """ + CREATE TABLE IF NOT EXISTS counter_read_model ( + model_id TEXT PRIMARY KEY, + amount BIGINT NOT NULL, + last_seen BIGINT NOT NULL, + source_event_id UUID UNIQUE, + actor TEXT + ) + """ + +-- A read model whose data table lives in an application-configured schema +-- (@app_reads@), demonstrating EP-4's configurable projection schema. Its SQL is +-- fully qualified via 'placedTable'; Keiro's own metadata stays in @keiro@. +placedTable :: Text +placedTable = qualifyTable "app_reads" "placed_counter" + +placedReadModel :: ReadModel Text Int +placedReadModel = + ReadModel + { name = "placed-counter-read-model" + , tableName = "placed_counter" + , schema = "app_reads" + , subscriptionName = "placed-counter-sub" + , version = 1 + , shapeHash = "placed-counter-v1" + , defaultConsistency = Eventual + , strongScope = EntireLog + , query = \modelId -> Tx.statement modelId selectPlacedStmt + } + +placedInlineProjection :: InlineProjection CounterEvent +placedInlineProjection = + InlineProjection + { name = "placed-inline-projection" + , apply = \event recorded -> + case event of + CounterAdded amount -> + Tx.statement + ( "placed" + , Prelude.fromIntegral amount + , globalPositionToInt (recorded ^. #globalPosition) + ) + upsertPlacedStmt + CounterAudited{} -> pure () + } + +initializePlacedTable :: Tx.Transaction () +initializePlacedTable = + Tx.sql $ + TE.encodeUtf8 $ + "CREATE TABLE IF NOT EXISTS " + <> placedTable + <> " (\n" + <> " model_id TEXT PRIMARY KEY,\n" + <> " amount BIGINT NOT NULL,\n" + <> " last_seen BIGINT NOT NULL\n" + <> ")" + +upsertPlacedStmt :: Statement (Text, Int64, Int64) () +upsertPlacedStmt = + preparable + ( "INSERT INTO " + <> placedTable + <> " (model_id, amount, last_seen)\n" + <> "VALUES ($1, $2, $3)\n" + <> "ON CONFLICT (model_id) DO UPDATE\n" + <> " SET amount = EXCLUDED.amount, last_seen = EXCLUDED.last_seen" + ) + ( contrazip3 + (E.param (E.nonNullable E.text)) + (E.param (E.nonNullable E.int8)) + (E.param (E.nonNullable E.int8)) + ) + D.noResult + +selectPlacedStmt :: Statement Text Int +selectPlacedStmt = + preparable + ("SELECT COALESCE((SELECT amount FROM " <> placedTable <> " WHERE model_id = $1), 0)") + (E.param (E.nonNullable E.text)) + (D.singleRow (Prelude.fromIntegral <$> D.column (D.nonNullable D.int8))) + +-- Count matching base tables in a given schema; proves table placement. +pgTableCountStmt :: Statement (Text, Text) Int +pgTableCountStmt = + preparable + "SELECT count(*)::int FROM pg_tables WHERE schemaname = $1 AND tablename = $2" + ( contrazip2 + (E.param (E.nonNullable E.text)) + (E.param (E.nonNullable E.text)) + ) + (D.singleRow (Prelude.fromIntegral <$> D.column (D.nonNullable D.int4))) + +initializeProjectionDedupCounterTable :: Tx.Transaction () +initializeProjectionDedupCounterTable = + Tx.sql + """ + CREATE TABLE IF NOT EXISTS projection_dedup_counter ( + id BOOLEAN PRIMARY KEY DEFAULT TRUE, + amount BIGINT NOT NULL + ); + + INSERT INTO projection_dedup_counter (id, amount) + VALUES (TRUE, 0) + ON CONFLICT (id) DO NOTHING; + """ + +upsertCounterReadModelStmt :: Statement (Text, Int64, Int64, Maybe UUID, Maybe Text) () +upsertCounterReadModelStmt = + preparable + """ + INSERT INTO counter_read_model (model_id, amount, last_seen, source_event_id, actor) + VALUES ($1, $2, $3, $4, $5) + ON CONFLICT (source_event_id) DO NOTHING + """ + ( contrazip5 + (E.param (E.nonNullable E.text)) + (E.param (E.nonNullable E.int8)) + (E.param (E.nonNullable E.int8)) + (E.param (E.nullable E.uuid)) + (E.param (E.nullable E.text)) + ) + D.noResult + +incrementProjectionDedupCounterStmt :: Statement () () +incrementProjectionDedupCounterStmt = + preparable + """ + UPDATE projection_dedup_counter + SET amount = amount + 1 + WHERE id = TRUE + """ + E.noParams + D.noResult + +selectProjectionDedupCounterStmt :: Statement () Int +selectProjectionDedupCounterStmt = + preparable + """ + SELECT amount + FROM projection_dedup_counter + WHERE id = TRUE + """ + E.noParams + (D.singleRow (Prelude.fromIntegral <$> D.column (D.nonNullable D.int8))) + +projectionDedupCountStmt :: Statement Text Int64 +projectionDedupCountStmt = + preparable + """ + SELECT count(*) + FROM keiro.keiro_projection_dedup + WHERE projection_name = $1 + """ + (E.param (E.nonNullable E.text)) + (D.singleRow (D.column (D.nonNullable D.int8))) + +selectCounterMetaStmt :: Statement Text (Int64, Maybe Text, Maybe UUID) +selectCounterMetaStmt = + preparable + """ + SELECT amount, actor, source_event_id + FROM counter_read_model + WHERE model_id = $1 + """ + (E.param (E.nonNullable E.text)) + ( D.singleRow + ( (,,) + <$> D.column (D.nonNullable D.int8) + <*> D.column (D.nullable D.text) + <*> D.column (D.nullable D.uuid) + ) + ) + +selectCounterReadModelStmt :: Statement Text Int +selectCounterReadModelStmt = + preparable + """ + SELECT COALESCE((SELECT amount FROM counter_read_model WHERE model_id = $1), 0) + """ + (E.param (E.nonNullable E.text)) + (D.singleRow (Prelude.fromIntegral <$> D.column (D.nonNullable D.int8))) + +upsertSubscriptionCursorStmt :: Statement (Text, Int64) () +upsertSubscriptionCursorStmt = + preparable + """ + INSERT INTO subscriptions (subscription_name, stream_name, last_seen) + VALUES ($1, '$all', $2) + ON CONFLICT (subscription_name, consumer_group_member) DO UPDATE + SET last_seen = EXCLUDED.last_seen, + updated_at = now() + """ + ( contrazip2 + (E.param (E.nonNullable E.text)) + (E.param (E.nonNullable E.int8)) + ) + D.noResult + +upsertSubscriptionCursorMemberStmt :: Statement (Text, Int32, Int64) () +upsertSubscriptionCursorMemberStmt = + preparable + """ + INSERT INTO subscriptions (subscription_name, stream_name, consumer_group_member, consumer_group_size, last_seen) + VALUES ($1, '$all', $2, 2, $3) + ON CONFLICT (subscription_name, consumer_group_member) DO UPDATE + SET last_seen = EXCLUDED.last_seen, + updated_at = now() + """ + ( contrazip3 + (E.param (E.nonNullable E.text)) + (E.param (E.nonNullable E.int4)) + (E.param (E.nonNullable E.int8)) + ) + D.noResult + +updateReadModelVersionStmt :: Statement (Text, Int64) () +updateReadModelVersionStmt = + preparable + """ + UPDATE keiro.keiro_read_models + SET version = $2 + WHERE name = $1 + """ + ( contrazip2 + (E.param (E.nonNullable E.text)) + (E.param (E.nonNullable E.int8)) + ) + D.noResult + +updateReadModelStatusStmt :: Statement (Text, Text) () +updateReadModelStatusStmt = + preparable + """ + UPDATE keiro.keiro_read_models + SET status = $2 + WHERE name = $1 + """ + ( contrazip2 + (E.param (E.nonNullable E.text)) + (E.param (E.nonNullable E.text)) + ) + D.noResult + +readModelXminStmt :: Statement Text Text +readModelXminStmt = + preparable + """ + SELECT xmin::text + FROM keiro.keiro_read_models + WHERE name = $1 + """ + (E.param (E.nonNullable E.text)) + (D.singleRow (D.column (D.nonNullable D.text))) + +globalPositionToInt :: GlobalPosition -> Int64 +globalPositionToInt (GlobalPosition value) = value + +eventIdToUuid :: EventId -> UUID +eventIdToUuid (EventId value) = value + +metadataActor :: RecordedEvent -> Maybe Text +metadataActor recorded = do + Aeson.Object o <- recorded ^. #metadata + Aeson.String s <- KeyMap.lookup "actor" o + pure s + +-- Router test fixtures: an effectful, data-dependent fan-out whose target set +-- is stored in a read-model table (router_targets) rather than computed purely. + +newtype RouteGroup = RouteGroup Text + deriving stock (Generic, Eq, Show) + +{- | Maps a routing group to the list of target counter stream identifiers seeded +for it. The query is genuinely effectful: 'demoRouter' calls it via 'runQuery'. +-} +routerTargetsReadModel :: ReadModel Text [Text] +routerTargetsReadModel = + ReadModel + { name = "router-targets-read-model" + , tableName = "router_targets" + , schema = "kiroku" + , subscriptionName = "router-targets-sub" + , version = 1 + , shapeHash = "router-targets-v1" + , defaultConsistency = Eventual + , strongScope = EntireLog + , query = \groupId -> Tx.statement groupId selectRouterTargetsStmt + } + +demoRouter :: + (IOE :> es, Store :> es) => + Router + RouteGroup + (HsPred '[] CounterCommand) + '[] + CounterState + CounterCommand + CounterEvent + es +demoRouter = + Router + { name = "demo-router" + , key = \(RouteGroup g) -> g + , resolve = \(RouteGroup g) -> do + result <- runQuery Nothing routerTargetsReadModel g + pure $ case result of + Right targetIds -> + [ PMCommand{target = stream targetId, command = Add 1} + | targetId <- targetIds + ] + Left _ -> [] + , targetEventStream = counterEventStream + , targetProjections = const [] + } + +unstableRouter :: + (IOE :> es) => + IORef Int -> + (Int -> [Text]) -> + Router + RouteGroup + (HsPred '[] CounterCommand) + '[] + CounterState + CounterCommand + CounterEvent + es +unstableRouter attemptsRef targetsFor = + Router + { name = "unstable-router" + , key = \(RouteGroup g) -> g + , resolve = \_ -> do + attempt <- liftIO (atomicModifyIORef' attemptsRef (\n -> (n + 1, n))) + pure + [ PMCommand{target = stream targetId, command = Add 1} + | targetId <- targetsFor attempt + ] + , targetEventStream = counterEventStream + , targetProjections = const [] + } + +isAppended :: PMCommandResult target -> Bool +isAppended = \case + PMCommandAppended{} -> True + _ -> False + +isDuplicate :: PMCommandResult target -> Bool +isDuplicate = \case + PMCommandDuplicate{} -> True + _ -> False + +initializeRouterTargetsTable :: Tx.Transaction () +initializeRouterTargetsTable = + Tx.sql + """ + CREATE TABLE IF NOT EXISTS router_targets ( + group_id TEXT NOT NULL, + target_id TEXT NOT NULL + ) + """ + +insertRouterTargetStmt :: Statement (Text, Text) () +insertRouterTargetStmt = + preparable + """ + INSERT INTO router_targets (group_id, target_id) + VALUES ($1, $2) + """ + ( contrazip2 + (E.param (E.nonNullable E.text)) + (E.param (E.nonNullable E.text)) + ) + D.noResult + +selectRouterTargetsStmt :: Statement Text [Text] +selectRouterTargetsStmt = + preparable + """ + SELECT target_id + FROM router_targets + WHERE group_id = $1 + ORDER BY target_id + """ + (E.param (E.nonNullable E.text)) + (D.rowList (D.column (D.nonNullable D.text))) + +-- Router worker fixtures: an in-memory Shibuya adapter that records every +-- finalized AckDecision, plus a router whose dispatch always fails. + +inMemoryAdapter :: + (IOE :> es) => + IORef [AckDecision] -> + [msg] -> + Adapter es msg +inMemoryAdapter decisionsRef messages = + Adapter + { adapterName = "router-test-adapter" + , source = Streamly.fromList (fmap ingest messages) + , shutdown = pure () + } + where + ingest message = + Ingested + { envelope = routerTestEnvelope message + , ack = AckHandle (\decision -> liftIO (modifyIORef' decisionsRef (<> [decision]))) + , lease = Nothing + } + +routerTestEnvelope :: msg -> Envelope msg +routerTestEnvelope message = + Envelope + { messageId = "router-test-message" + , cursor = Nothing + , partition = Nothing + , enqueuedAt = Nothing + , traceContext = Nothing + , headers = Nothing + , attempt = Nothing + , attributes = mempty + , payload = message + } + +{- | A target aggregate with no outgoing edges: every command is rejected +(CommandRejected), so a dispatch through it surfaces as PMCommandFailed, +driving the worker's AckHalt branch. +-} +rejectingEventStreamDef :: CounterEventStream +rejectingEventStreamDef = + counterEventStreamDef & #transducer .~ rejectingTransducer + +rejectingEventStream :: ValidatedCounterEventStream +rejectingEventStream = mkEventStreamOrThrow "rejecting-counter" rejectingEventStreamDef + +{- | Accept every Add command except amount 9, which exercises a worker that +dead-letters one rejected dispatch and then successfully processes the next. +-} +rejectNineEventStream :: ValidatedCounterEventStream +rejectNineEventStream = mkEventStreamOrThrow "reject-nine-counter" rejectNineEventStreamDef + +rejectNineEventStreamDef :: CounterEventStream +rejectNineEventStreamDef = + counterEventStreamDef & #transducer .~ rejectNineTransducer + +rejectNineTransducer :: SymTransducer (HsPred '[] CounterCommand) '[] CounterState CounterCommand CounterEvent +rejectNineTransducer = + SymTransducer + { edgesOut = \case + Counting -> + [ Edge + { guard = + PAnd + (matchInCtor addCtor) + (PNot (inpCtor addCtor #amount .== Keiki.lit 9)) + , update = UKeep + , output = [pack addCtor counterAddedCtor (inpCtor addCtor #amount *: oNil)] + , target = Counting + } + ] + , initial = Counting + , initialRegs = RNil + , isFinal = \_ -> False + } + +rejectingTransducer :: SymTransducer (HsPred '[] CounterCommand) '[] CounterState CounterCommand CounterEvent +rejectingTransducer = + SymTransducer + { edgesOut = \case + Counting -> [] + , initial = Counting + , initialRegs = RNil + , isFinal = \_ -> False + } + +failingRouter :: + Router + RouteGroup + (HsPred '[] CounterCommand) + '[] + CounterState + CounterCommand + CounterEvent + es +failingRouter = + Router + { name = "failing-router" + , key = \(RouteGroup g) -> g + , resolve = \_ -> pure [PMCommand{target = stream "failing-target", command = Add 1}] + , targetEventStream = rejectingEventStream + , targetProjections = const [] + } + +-- Flatten exported counter/gauge points to (instrument name, value). +flattenScalarPoints :: [ResourceMetricsExport] -> [(Text, NumberValue)] +flattenScalarPoints rmes = + [ (name, val) + | rme <- rmes + , scope <- Vector.toList (resourceMetricsScopes rme) + , export <- Vector.toList (scopeMetricsExports scope) + , (name, val) <- pointsOf export + ] + where + pointsOf (MetricExportSum n _ _ _ _ _ _ pts) = + [(n, sumDataPointValue p) | p <- Vector.toList pts] + pointsOf (MetricExportGauge n _ _ _ _ pts) = + [(n, gaugeDataPointValue p) | p <- Vector.toList pts] + pointsOf _ = [] + +-- Flatten exported histogram points to (instrument name, count, sum). +flattenHistogramPoints :: [ResourceMetricsExport] -> [(Text, Word64, Double)] +flattenHistogramPoints rmes = + [ (n, histogramDataPointCount p, histogramDataPointSum p) + | rme <- rmes + , scope <- Vector.toList (resourceMetricsScopes rme) + , export <- Vector.toList (scopeMetricsExports scope) + , MetricExportHistogram n _ _ _ _ pts <- [export] + , p <- Vector.toList pts + ] + +-- =========================================================================== +-- EP-51 sharded-subscription test helpers +-- =========================================================================== + +-- A test sink the sharded handlers write to: one row per processed event, +-- idempotent on event_id (an at-least-once handler may redeliver during a +-- rebalance). worker_tag identifies which worker process handled it; stream_id +-- is the originating stream (the partition key kiroku hashes on). +createShardSinkSql :: ByteString +createShardSinkSql = + "CREATE TABLE IF NOT EXISTS shard_sink \ + \(event_id uuid PRIMARY KEY, worker_tag int NOT NULL, stream_id bigint NOT NULL)" + +-- Seed @nStreams@ category-@orders@ streams with @perStream@ events each +-- (upsert append, so it is safe to call twice in one test). Returns the total +-- number of events appended. +seedOrders :: Store.KirokuStore -> Int -> Int -> IO Int +seedOrders store nStreams perStream = do + for_ [0 .. nStreams - 1] $ \i -> do + let sname = StreamName ("orders-" <> Text.pack (show i)) + evs = + [ EventData + { eventId = Nothing + , eventType = EventType "OrderPlaced" + , payload = object ["n" Aeson..= (j :: Int)] + , metadata = Nothing + , causationId = Nothing + , correlationId = Nothing + } + | j <- [0 .. perStream - 1] + ] + Right _ <- Store.runStoreIO store $ Store.appendToStream sname AnyVersion evs + pure () + pure (nStreams * perStream) + +-- A handler for worker @tag@: idempotently record (event_id, tag, stream_id). +sinkHandler :: Store.KirokuStore -> Int32 -> RecordedEvent -> IO () +sinkHandler store tag ev = + void $ + Store.runStoreIO store $ + Store.runTransaction $ + Tx.statement (eventUuid (ev ^. #eventId), tag, streamIdInt (ev ^. #originalStreamId)) insertShardSinkStmt + where + eventUuid (EventId u) = u + streamIdInt (StreamId s) = s + +insertShardSinkStmt :: Statement (UUID, Int32, Int64) () +insertShardSinkStmt = + preparable + "INSERT INTO shard_sink (event_id, worker_tag, stream_id) VALUES ($1, $2, $3) ON CONFLICT (event_id) DO NOTHING" + ( contrazip3 + (E.param (E.nonNullable E.uuid)) + (E.param (E.nonNullable E.int4)) + (E.param (E.nonNullable E.int8)) + ) + D.noResult + +shardSinkCount :: Store.KirokuStore -> IO Int +shardSinkCount store = + either (const 0) id + <$> Store.runStoreIO store (Store.runTransaction (Tx.statement () countShardSinkStmt)) + +countShardSinkStmt :: Statement () Int +countShardSinkStmt = + preparable + "SELECT count(*) FROM shard_sink" + E.noParams + (D.singleRow (fromIntegral <$> D.column (D.nonNullable D.int8))) + +shardDeadLetterDetails :: Store.KirokuStore -> Text -> IO (Int, Maybe Text, Maybe Int) +shardDeadLetterDetails store subscription = + either (const (0, Nothing, Nothing)) id + <$> Store.runStoreIO store (Store.runTransaction (Tx.statement subscription shardDeadLetterDetailsStmt)) + +shardDeadLetterDetailsStmt :: Statement Text (Int, Maybe Text, Maybe Int) +shardDeadLetterDetailsStmt = + preparable + "SELECT count(*)::bigint, max(reason_summary), max(attempt_count) \ + \FROM kiroku.dead_letters \ + \WHERE subscription_name = $1 AND consumer_group_member = 0" + (E.param (E.nonNullable E.text)) + ( D.singleRow $ + (,,) + <$> (fromIntegral <$> D.column (D.nonNullable D.int8)) + <*> D.column (D.nullable D.text) + <*> (fmap fromIntegral <$> D.column (D.nullable D.int4)) + ) + +-- The largest number of distinct workers that processed any single stream. 1 +-- means perfectly disjoint ownership (no stream split across workers). +maxWorkersPerStream :: Store.KirokuStore -> IO Int +maxWorkersPerStream store = + either (const 0) id + <$> Store.runStoreIO store (Store.runTransaction (Tx.statement () maxWorkersPerStreamStmt)) + +maxWorkersPerStreamStmt :: Statement () Int +maxWorkersPerStreamStmt = + preparable + "SELECT COALESCE(MAX(c), 0) FROM \ + \(SELECT count(DISTINCT worker_tag) AS c FROM shard_sink GROUP BY stream_id) s" + E.noParams + (D.singleRow (fromIntegral <$> D.column (D.nonNullable D.int8))) + +-- How many distinct workers processed at least one event (proves the work +-- spread across the pool rather than monopolised by one worker). +distinctWorkers :: Store.KirokuStore -> IO Int +distinctWorkers store = + either (const 0) id + <$> Store.runStoreIO store (Store.runTransaction (Tx.statement () distinctWorkersStmt)) + +distinctWorkersStmt :: Statement () Int +distinctWorkersStmt = + preparable + "SELECT count(DISTINCT worker_tag) FROM shard_sink" + E.noParams + (D.singleRow (fromIntegral <$> D.column (D.nonNullable D.int8))) + +-- Poll the sink count until it reaches @target@ or the timeout elapses. +waitUntilSinkCount :: Store.KirokuStore -> Int -> Int -> IO Bool +waitUntilSinkCount store target timeoutMicros = go (max 1 (timeoutMicros `div` step)) + where + step = 100_000 + go :: Int -> IO Bool + go 0 = (>= target) <$> shardSinkCount store + go n = do + c <- shardSinkCount store + if c >= target + then pure True + else threadDelay step >> go (n - 1) + +-- Poll until at least @target@ shard rows have a live owner. Tests use this to +-- join a second worker at a precise point in the one-bucket-per-pass ramp-up. +waitUntilOwnedShardCount :: Store.KirokuStore -> SubscriptionName -> Int -> Int -> IO Bool +waitUntilOwnedShardCount store sub target timeoutMicros = go (max 1 (timeoutMicros `div` step)) + where + step = 50_000 + go 0 = hasTarget + go n = do + reached <- hasTarget + if reached then pure True else threadDelay step >> go (n - 1) + hasTarget = do + rows <- either (const []) id <$> Store.runStoreIO store (Store.runTransaction (listShardOwnership sub)) + pure (length [() | (_, Just _, _) <- rows] >= target) + +-- Poll the lease table until cooperative ownership has converged: every bucket +-- owned, at least @minWorkers@ distinct owners, and no owner holding more than +-- its fair share. This is the "balanced on the empty category" gate the +-- failover test waits on before seeding, so the drain runs under stable +-- membership. +waitShardsBalanced :: Store.KirokuStore -> SubscriptionName -> Int -> Int -> Int -> IO Bool +waitShardsBalanced store sub n minWorkers timeoutMicros = go (max 1 (timeoutMicros `div` step)) + where + step = 200_000 + go :: Int -> IO Bool + go 0 = isBalanced + go k = do + ok <- isBalanced + if ok then pure True else threadDelay step >> go (k - 1) + isBalanced :: IO Bool + isBalanced = do + rows <- either (const []) id <$> Store.runStoreIO store (Store.runTransaction (listShardOwnership sub)) + let owners = [w | (_, Just w, _) <- rows] + distinct = length (nubOrd owners) + perOwner = [length g | g <- groupByOwner owners] + fairShare = (n + max 1 distinct - 1) `div` max 1 distinct + pure (length rows == n && length owners == n && distinct >= minWorkers && all (<= fairShare) perOwner) + groupByOwner ws = [filter (== w) ws | w <- nubOrd ws] + nubOrd = Set.toList . Set.fromList + +waitShardsUnowned :: Store.KirokuStore -> SubscriptionName -> Int -> Int -> IO Bool +waitShardsUnowned store sub n timeoutMicros = go (max 1 (timeoutMicros `div` step)) + where + step = 100_000 + go 0 = isUnowned + go k = do + ok <- isUnowned + if ok then pure True else threadDelay step >> go (k - 1) + isUnowned = do + rows <- either (const []) id <$> Store.runStoreIO store (Store.runTransaction (listShardOwnership sub)) + pure (length rows == n && all (\(_, owner, _) -> isNothing owner) rows) + +workflowOwnedRowCounts :: (Store :> es) => Text -> Text -> Eff es (Int64, Int64, Int64, Int64, Int64, Int64) +workflowOwnedRowCounts name wid = + Store.runTransaction (Tx.statement (wid, name) workflowOwnedRowCountsStmt) + +workflowOwnedChildCount :: (Store :> es) => Text -> Text -> Eff es Int64 +workflowOwnedChildCount name wid = + Store.runTransaction (Tx.statement (wid, name, wid, name) workflowOwnedChildCountStmt) + +workflowWakeAfter :: (Store :> es) => WorkflowName -> WorkflowId -> Eff es (Maybe UTCTime) +workflowWakeAfter (WorkflowName name) (WorkflowId wid) = + Store.runTransaction (Tx.statement (wid, name) workflowWakeAfterStmt) + +insertGcTimerStmt :: Statement (UUID, Text, Text, UTCTime, Value, Text) () +insertGcTimerStmt = + preparable + """ + INSERT INTO keiro.keiro_timers + (timer_id, process_manager_name, correlation_id, fire_at, payload, status) + VALUES ($1, $2, $3, $4, $5, $6) + """ + ( contrazip6 + (E.param (E.nonNullable E.uuid)) + (E.param (E.nonNullable E.text)) + (E.param (E.nonNullable E.text)) + (E.param (E.nonNullable E.timestamptz)) + (E.param (E.nonNullable E.jsonb)) + (E.param (E.nonNullable E.text)) + ) + D.noResult + +deleteGcStepsStmt :: Statement (Text, Text) () +deleteGcStepsStmt = + preparable + """ + DELETE FROM keiro.keiro_workflow_steps + WHERE workflow_id = $1 AND workflow_name = $2 + """ + ( contrazip2 + (E.param (E.nonNullable E.text)) + (E.param (E.nonNullable E.text)) + ) + D.noResult + +deleteWorkflowInstanceStmt :: Statement (Text, Text) () +deleteWorkflowInstanceStmt = + preparable + """ + DELETE FROM keiro.keiro_workflows + WHERE workflow_id = $1 AND workflow_name = $2 + """ + ( contrazip2 + (E.param (E.nonNullable E.text)) + (E.param (E.nonNullable E.text)) + ) + D.noResult + +workflowWakeAfterStmt :: Statement (Text, Text) (Maybe UTCTime) +workflowWakeAfterStmt = + preparable + """ + SELECT wake_after + FROM keiro.keiro_workflows + WHERE workflow_id = $1 AND workflow_name = $2 + """ + ( contrazip2 + (E.param (E.nonNullable E.text)) + (E.param (E.nonNullable E.text)) + ) + (maybe Nothing id <$> D.rowMaybe (D.column (D.nullable D.timestamptz))) + +workflowOwnedRowCountsStmt :: Statement (Text, Text) (Int64, Int64, Int64, Int64, Int64, Int64) +workflowOwnedRowCountsStmt = + preparable + """ + SELECT + (SELECT count(*) FROM keiro.keiro_workflows WHERE workflow_id = $1 AND workflow_name = $2), + (SELECT count(*) FROM keiro.keiro_workflow_steps WHERE workflow_id = $1 AND workflow_name = $2), + (SELECT count(*) FROM keiro.keiro_awakeables WHERE owner_workflow_id = $1 AND owner_workflow_name = $2), + (SELECT count(*) FROM keiro.keiro_workflow_children + WHERE (parent_id = $1 AND parent_name = $2) OR (child_id = $1 AND child_name = $2)), + (SELECT count(*) FROM keiro.keiro_timers + WHERE correlation_id = $1 AND process_manager_name = $2 AND payload->>'kind' = 'keiro.workflow.sleep'), + (SELECT count(*) + FROM keiro.keiro_snapshots s + JOIN streams st ON st.stream_id = s.stream_id + WHERE st.stream_name = 'wf:' || $2 || '-' || $1) + """ + ( contrazip2 + (E.param (E.nonNullable E.text)) + (E.param (E.nonNullable E.text)) + ) + ( D.singleRow $ + (,,,,,) + <$> D.column (D.nonNullable D.int8) + <*> D.column (D.nonNullable D.int8) + <*> D.column (D.nonNullable D.int8) + <*> D.column (D.nonNullable D.int8) + <*> D.column (D.nonNullable D.int8) + <*> D.column (D.nonNullable D.int8) + ) + +workflowOwnedChildCountStmt :: Statement (Text, Text, Text, Text) Int64 +workflowOwnedChildCountStmt = + preparable + """ + SELECT count(*) + FROM keiro.keiro_workflow_children + WHERE (parent_id = $1 AND parent_name = $2) + OR (child_id = $3 AND child_name = $4) + """ + ( contrazip4 + (E.param (E.nonNullable E.text)) + (E.param (E.nonNullable E.text)) + (E.param (E.nonNullable E.text)) + (E.param (E.nonNullable E.text)) + ) + (D.singleRow (D.column (D.nonNullable D.int8)))