diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -6,6 +6,20 @@ ## [Unreleased] +## 0.6.0.0 — 2026-07-31 + +### Breaking Changes + +- Requires the exact-`Integer` / total-`Natural` Keiki releases + (`keiki >=0.6 && <0.7`, `keiki-codec-json >=0.6 && <0.7`), replacing the + previous `>=0.4 && <0.5` bounds. + +### New Features + +- Re-exports `Keiro.Codec.Nominal` from `keiro-core`, so generated nominal + consumer bindings keep a single direct `keiro` dependency alongside the + existing structural binding re-exports. + ## 0.5.0.0 — 2026-07-31 No changes this release. Released with the package set for the `keiro-dsl` diff --git a/bench/Main.hs b/bench/Main.hs --- a/bench/Main.hs +++ b/bench/Main.hs @@ -1,9 +1,9 @@ {-# LANGUAGE BlockArguments #-} {-# LANGUAGE OverloadedRecordDot #-} -module Main ( - main, -) +module Main + ( main, + ) where import Control.Concurrent (threadDelay) @@ -14,24 +14,24 @@ import Data.UUID qualified as UUID import Effectful (Eff, IOE, (:>)) import Effectful.Error.Static (Error) -import Keiro.Inbox ( - InboxDedupePolicy (..), +import Keiro.Inbox + ( InboxDedupePolicy (..), InboxPersistence (..), InboxResult (..), KafkaDeliveryRef (..), runInboxTransactionBatch, runInboxTransactionWith, - ) + ) import Keiro.Integration.Event (IntegrationContentType (..), IntegrationEvent (..)) -import Keiro.Outbox ( - OutboxId (..), +import Keiro.Outbox + ( OutboxId (..), OutboxRow, PublishOutcome (..), countOutboxBacklog, defaultPublishOptions, enqueueIntegrationEventTx, publishClaimedOutbox, - ) + ) import Keiro.Prelude import Keiro.Telemetry qualified as Telemetry import Keiro.Test.Postgres (withFreshStore, withMigratedSuite) @@ -59,247 +59,247 @@ fixedOccurredAt = UTCTime (ModifiedJulianDay 61000) (secondsToDiffTime 0) data BrokerModel = BrokerModel - { invocationMicros :: !Int - , perRecordMicros :: !Int - } - deriving stock (Eq, Show) + { invocationMicros :: !Int, + perRecordMicros :: !Int + } + deriving stock (Eq, Show) data OutboxScenario = OutboxScenario - { scenarioName :: !Text - , brokerModel :: !BrokerModel - , messages :: ![(OutboxId, IntegrationEvent)] - } + { scenarioName :: !Text, + brokerModel :: !BrokerModel, + messages :: ![(OutboxId, IntegrationEvent)] + } data InboxScenario = InboxScenario - { inboxScenarioName :: !Text - , inboxMetrics :: !(Maybe Telemetry.KeiroMetrics) - , inboxPersistence :: !InboxPersistence - , inboxBatchSize :: !(Maybe Int) - , inboxMessages :: ![(IntegrationEvent, KafkaDeliveryRef)] - } + { inboxScenarioName :: !Text, + inboxMetrics :: !(Maybe Telemetry.KeiroMetrics), + inboxPersistence :: !InboxPersistence, + inboxBatchSize :: !(Maybe Int), + inboxMessages :: ![(IntegrationEvent, KafkaDeliveryRef)] + } main :: IO () main = - withMigratedSuite \fixture -> - withFreshStore fixture \store -> do - (provider, _env) <- - createMeterProvider - emptyMaterializedResources - defaultSdkMeterProviderOptions - meter <- getMeter provider Telemetry.keiroInstrumentationLibrary - metrics <- Telemetry.newKeiroMetrics meter - defaultMain (benchmarks store metrics) + withMigratedSuite \fixture -> + withFreshStore fixture \store -> do + (provider, _env) <- + createMeterProvider + emptyMaterializedResources + defaultSdkMeterProviderOptions + meter <- getMeter provider Telemetry.keiroInstrumentationLibrary + metrics <- Telemetry.newKeiroMetrics meter + defaultMain (benchmarks store metrics) benchmarks :: Store.KirokuStore -> Telemetry.KeiroMetrics -> [Benchmark] benchmarks store metrics = - [ bgroup - "outbox" - [ scenarioBench store hotKey - , scenarioBench store hotKeyNoLatency - , scenarioBench store multiKey - ] - , bgroup - "inbox" - [ inboxScenarioBench store (singleFull metrics) - , inboxScenarioBench store singleNoMetrics - , inboxScenarioBench store batch100 - , inboxScenarioBench store singleSlim - ] - ] + [ bgroup + "outbox" + [ scenarioBench store hotKey, + scenarioBench store hotKeyNoLatency, + scenarioBench store multiKey + ], + bgroup + "inbox" + [ inboxScenarioBench store (singleFull metrics), + inboxScenarioBench store singleNoMetrics, + inboxScenarioBench store batch100, + inboxScenarioBench store singleSlim + ] + ] where hotKey = - OutboxScenario - { scenarioName = "hot-key" - , brokerModel = BrokerModel{invocationMicros = 1000, perRecordMicros = 10} - , messages = scenarioMessages \_ -> Just "aggregate-hot" - } + OutboxScenario + { scenarioName = "hot-key", + brokerModel = BrokerModel {invocationMicros = 1000, perRecordMicros = 10}, + messages = scenarioMessages \_ -> Just "aggregate-hot" + } hotKeyNoLatency = - OutboxScenario - { scenarioName = "hot-key-nolatency" - , brokerModel = BrokerModel{invocationMicros = 0, perRecordMicros = 0} - , messages = scenarioMessages \_ -> Just "aggregate-hot" - } + OutboxScenario + { scenarioName = "hot-key-nolatency", + brokerModel = BrokerModel {invocationMicros = 0, perRecordMicros = 0}, + messages = scenarioMessages \_ -> Just "aggregate-hot" + } multiKey = - OutboxScenario - { scenarioName = "multi-key" - , brokerModel = BrokerModel{invocationMicros = 1000, perRecordMicros = 10} - , messages = scenarioMessages \i -> Just ("aggregate-" <> Text.pack (show (i `mod` 200))) - } + OutboxScenario + { scenarioName = "multi-key", + brokerModel = BrokerModel {invocationMicros = 1000, perRecordMicros = 10}, + messages = scenarioMessages \i -> Just ("aggregate-" <> Text.pack (show (i `mod` 200))) + } singleFull metrics' = - InboxScenario - { inboxScenarioName = "single-full" - , inboxMetrics = Just metrics' - , inboxPersistence = PersistFullEnvelope - , inboxBatchSize = Nothing - , inboxMessages = inboxScenarioMessages - } + InboxScenario + { inboxScenarioName = "single-full", + inboxMetrics = Just metrics', + inboxPersistence = PersistFullEnvelope, + inboxBatchSize = Nothing, + inboxMessages = inboxScenarioMessages + } singleNoMetrics = - InboxScenario - { inboxScenarioName = "single-nometrics" - , inboxMetrics = Nothing - , inboxPersistence = PersistFullEnvelope - , inboxBatchSize = Nothing - , inboxMessages = inboxScenarioMessages - } + InboxScenario + { inboxScenarioName = "single-nometrics", + inboxMetrics = Nothing, + inboxPersistence = PersistFullEnvelope, + inboxBatchSize = Nothing, + inboxMessages = inboxScenarioMessages + } batch100 = - InboxScenario - { inboxScenarioName = "batch-100" - , inboxMetrics = Nothing - , inboxPersistence = PersistFullEnvelope - , inboxBatchSize = Just 100 - , inboxMessages = inboxScenarioMessages - } + InboxScenario + { inboxScenarioName = "batch-100", + inboxMetrics = Nothing, + inboxPersistence = PersistFullEnvelope, + inboxBatchSize = Just 100, + inboxMessages = inboxScenarioMessages + } singleSlim = - InboxScenario - { inboxScenarioName = "single-slim" - , inboxMetrics = Nothing - , inboxPersistence = PersistDedupeOnly - , inboxBatchSize = Nothing - , inboxMessages = inboxScenarioMessages - } + InboxScenario + { inboxScenarioName = "single-slim", + inboxMetrics = Nothing, + inboxPersistence = PersistDedupeOnly, + inboxBatchSize = Nothing, + inboxMessages = inboxScenarioMessages + } scenarioBench :: Store.KirokuStore -> OutboxScenario -> Benchmark scenarioBench store scenario = - bench (Text.unpack scenario.scenarioName) $ - nfIO (runScenario store scenario) + bench (Text.unpack scenario.scenarioName) $ + nfIO (runScenario store scenario) runScenario :: Store.KirokuStore -> OutboxScenario -> IO () runScenario store scenario = do - runStoreChecked store do - Store.runTransaction (Tx.sql "TRUNCATE keiro_outbox") - seedOutbox store scenario.messages - runStoreChecked store (drainOutbox scenario.brokerModel 0) + runStoreChecked store do + Store.runTransaction (Tx.sql "TRUNCATE keiro_outbox") + seedOutbox store scenario.messages + runStoreChecked store (drainOutbox scenario.brokerModel 0) inboxScenarioBench :: Store.KirokuStore -> InboxScenario -> Benchmark inboxScenarioBench store scenario = - bench (Text.unpack scenario.inboxScenarioName) $ - nfIO (runInboxScenario store scenario) + bench (Text.unpack scenario.inboxScenarioName) $ + nfIO (runInboxScenario store scenario) runInboxScenario :: Store.KirokuStore -> InboxScenario -> IO () runInboxScenario store scenario = do - runStoreChecked store do - Store.runTransaction (Tx.sql "TRUNCATE keiro_inbox") - runStoreChecked store $ - case scenario.inboxBatchSize of - Nothing -> - traverse_ - (processInboxDelivery scenario.inboxMetrics scenario.inboxPersistence) - scenario.inboxMessages - Just batchSize -> - traverse_ - (processInboxBatch scenario.inboxMetrics scenario.inboxPersistence) - (chunksOf batchSize scenario.inboxMessages) + runStoreChecked store do + Store.runTransaction (Tx.sql "TRUNCATE keiro_inbox") + runStoreChecked store $ + case scenario.inboxBatchSize of + Nothing -> + traverse_ + (processInboxDelivery scenario.inboxMetrics scenario.inboxPersistence) + scenario.inboxMessages + Just batchSize -> + traverse_ + (processInboxBatch scenario.inboxMetrics scenario.inboxPersistence) + (chunksOf batchSize scenario.inboxMessages) processInboxDelivery :: - (IOE :> es, Store :> es) => - Maybe Telemetry.KeiroMetrics -> - InboxPersistence -> - (IntegrationEvent, KafkaDeliveryRef) -> - Eff es () + (IOE :> es, Store :> es) => + Maybe Telemetry.KeiroMetrics -> + InboxPersistence -> + (IntegrationEvent, KafkaDeliveryRef) -> + Eff es () processInboxDelivery mMetrics persistence (event, kafkaRef) = do - result <- runInboxTransactionWith mMetrics persistence PreferIntegrationMessageId event (Just kafkaRef) (\_ -> pure ()) - case result of - Right (InboxProcessed ()) -> pure () - other -> liftIO (fail ("unexpected inbox benchmark result: " <> show other)) + result <- runInboxTransactionWith mMetrics persistence PreferIntegrationMessageId event (Just kafkaRef) (\_ -> pure ()) + case result of + Right (InboxProcessed ()) -> pure () + other -> liftIO (fail ("unexpected inbox benchmark result: " <> show other)) processInboxBatch :: - (IOE :> es, Store :> es) => - Maybe Telemetry.KeiroMetrics -> - InboxPersistence -> - [(IntegrationEvent, KafkaDeliveryRef)] -> - Eff es () + (IOE :> es, Store :> es) => + Maybe Telemetry.KeiroMetrics -> + InboxPersistence -> + [(IntegrationEvent, KafkaDeliveryRef)] -> + Eff es () processInboxBatch mMetrics persistence chunk = do - results <- - runInboxTransactionBatch - mMetrics - 3 - PreferIntegrationMessageId - persistence - [(event, Just kafkaRef) | (event, kafkaRef) <- chunk] - (\_ -> pure ()) - for_ results \case - Right (InboxProcessed ()) -> pure () - other -> liftIO (fail ("unexpected inbox batch benchmark result: " <> show other)) + results <- + runInboxTransactionBatch + mMetrics + 3 + PreferIntegrationMessageId + persistence + [(event, Just kafkaRef) | (event, kafkaRef) <- chunk] + (\_ -> pure ()) + for_ results \case + Right (InboxProcessed ()) -> pure () + other -> liftIO (fail ("unexpected inbox batch benchmark result: " <> show other)) seedOutbox :: Store.KirokuStore -> [(OutboxId, IntegrationEvent)] -> IO () seedOutbox store messages = - traverse_ seedChunk (chunksOf seedChunkSize messages) + traverse_ seedChunk (chunksOf seedChunkSize messages) where seedChunk chunk = - runStoreChecked store $ - Store.runTransaction $ - traverse_ (uncurry enqueueIntegrationEventTx) chunk + runStoreChecked store $ + Store.runTransaction $ + traverse_ (uncurry enqueueIntegrationEventTx) chunk drainOutbox :: (IOE :> es, Store :> es) => BrokerModel -> Int -> Eff es () drainOutbox broker passes = do - backlog <- countOutboxBacklog - if backlog == 0 - then pure () - else do - when (passes >= maxDrainPasses) $ - liftIO (fail ("outbox benchmark exceeded safety cap of " <> show maxDrainPasses <> " passes")) - void (publishClaimedOutbox (simulatedPublish broker) defaultPublishOptions Nothing) - drainOutbox broker (passes + 1) + backlog <- countOutboxBacklog + if backlog == 0 + then pure () + else do + when (passes >= maxDrainPasses) $ + liftIO (fail ("outbox benchmark exceeded safety cap of " <> show maxDrainPasses <> " passes")) + void (publishClaimedOutbox (simulatedPublish broker) defaultPublishOptions Nothing) + drainOutbox broker (passes + 1) simulatedPublish :: (IOE :> es) => BrokerModel -> [OutboxRow] -> Eff es [(OutboxId, PublishOutcome)] simulatedPublish broker rows = do - let totalMicros = broker.invocationMicros + broker.perRecordMicros * length rows - when (totalMicros > 0) $ - liftIO (threadDelay totalMicros) - pure [(row ^. #outboxId, PublishSucceeded) | row <- rows] + let totalMicros = broker.invocationMicros + broker.perRecordMicros * length rows + when (totalMicros > 0) $ + liftIO (threadDelay totalMicros) + pure [(row ^. #outboxId, PublishSucceeded) | row <- rows] scenarioMessages :: (Int -> Maybe Text) -> [(OutboxId, IntegrationEvent)] scenarioMessages keyFor = - [ (OutboxId (UUID.fromWords64 0x018f0f1800007000 (0x8000000000000000 + fromIntegral i)), integrationEvent i (keyFor i)) - | i <- [1 .. workloadSize] - ] + [ (OutboxId (UUID.fromWords64 0x018f0f1800007000 (0x8000000000000000 + fromIntegral i)), integrationEvent i (keyFor i)) + | i <- [1 .. workloadSize] + ] integrationEvent :: Int -> Maybe Text -> IntegrationEvent integrationEvent i key = - IntegrationEvent - { messageId = "bench-msg-" <> Text.pack (show i) - , source = "bench.outbox" - , destination = "bench.outbox.events.v1" - , key - , eventType = "BenchEvent" - , schemaVersion = 1 - , contentType = ApplicationJson - , schemaReference = Nothing - , sourceEventId = Nothing - , sourceGlobalPosition = Nothing - , payloadBytes = BS.replicate payloadSize 65 - , occurredAt = fixedOccurredAt - , causationId = Nothing - , correlationId = Nothing - , traceContext = Nothing - , attributes = Nothing - } + IntegrationEvent + { messageId = "bench-msg-" <> Text.pack (show i), + source = "bench.outbox", + destination = "bench.outbox.events.v1", + key, + eventType = "BenchEvent", + schemaVersion = 1, + contentType = ApplicationJson, + schemaReference = Nothing, + sourceEventId = Nothing, + sourceGlobalPosition = Nothing, + payloadBytes = BS.replicate payloadSize 65, + occurredAt = fixedOccurredAt, + causationId = Nothing, + correlationId = Nothing, + traceContext = Nothing, + attributes = Nothing + } inboxScenarioMessages :: [(IntegrationEvent, KafkaDeliveryRef)] inboxScenarioMessages = - [ ( integrationEvent i (Just ("inbox-key-" <> Text.pack (show i))) - & #messageId - .~ ("bench-inbox-msg-" <> Text.pack (show i)) - & #source - .~ "bench.inbox" - & #destination - .~ "bench.inbox.events.v1" - , KafkaDeliveryRef "bench.inbox.events.v1" 0 (fromIntegral i) - ) - | i <- [1 .. workloadSize] - ] + [ ( integrationEvent i (Just ("inbox-key-" <> Text.pack (show i))) + & #messageId + .~ ("bench-inbox-msg-" <> Text.pack (show i)) + & #source + .~ "bench.inbox" + & #destination + .~ "bench.inbox.events.v1", + KafkaDeliveryRef "bench.inbox.events.v1" 0 (fromIntegral i) + ) + | i <- [1 .. workloadSize] + ] chunksOf :: Int -> [a] -> [[a]] chunksOf n xs - | n <= 0 = error "chunksOf: non-positive chunk size" - | otherwise = - case splitAt n xs of - ([], _) -> [] - (chunk, rest) -> chunk : chunksOf n rest + | n <= 0 = error "chunksOf: non-positive chunk size" + | otherwise = + case splitAt n xs of + ([], _) -> [] + (chunk, rest) -> chunk : chunksOf n rest runStoreChecked :: Store.KirokuStore -> Eff [Store, Error Store.StoreError, IOE] a -> IO a runStoreChecked store action = do - result <- Store.runStoreIO store action - case result of - Left err -> fail (show err) - Right value -> pure value + result <- Store.runStoreIO store action + case result of + Left err -> fail (show err) + Right value -> pure value diff --git a/keiro.cabal b/keiro.cabal --- a/keiro.cabal +++ b/keiro.cabal @@ -1,6 +1,6 @@ cabal-version: 3.0 name: keiro -version: 0.5.0.0 +version: 0.6.0.0 synopsis: Event sourcing framework and workflow engine description: A library that composes kiroku, keiki, and shibuya into an @@ -91,6 +91,7 @@ keiro-core:Keiro.Codec, keiro-core:Keiro.Codec.Structural, keiro-core:Keiro.Codec.Structural.Generic, + keiro-core:Keiro.Codec.Nominal, keiro-core:Keiro.EventStream, keiro-core:Keiro.EventStream.Validate, keiro-core:Keiro.Integration.Event, @@ -118,9 +119,9 @@ , hs-opentelemetry-api >=1.0 && <1.1 , hs-opentelemetry-propagator-w3c >=1.0 && <1.1 , hs-opentelemetry-semantic-conventions >=1.40 && <2 - , keiki >=0.4 && <0.5 - , keiki-codec-json >=0.4 && <0.5 - , keiro-core ^>=0.5.0.0 + , keiki >=0.6 && <0.7 + , keiki-codec-json >=0.6 && <0.7 + , keiro-core ^>=0.6.0.0 , kiroku-store >=0.3 && <0.4 , lens >=5.2 && <5.4 , mmzk-typeid >=0.7 && <0.8 @@ -188,7 +189,7 @@ , hs-opentelemetry-api >=1.0 && <1.1 , hs-opentelemetry-sdk >=1.0 && <1.1 , keiro - , keiro-core ^>=0.5.0.0 + , keiro-core ^>=0.6.0.0 , keiro-test-support , kiroku-store >=0.3 && <0.4 , tasty-bench >=0.4 diff --git a/src/Keiro.hs b/src/Keiro.hs --- a/src/Keiro.hs +++ b/src/Keiro.hs @@ -1,28 +1,27 @@ -{- | Umbrella entry point for the Keiro event-sourcing framework. - -Importing @Keiro@ brings the everyday command-side surface into scope in -one go: the command runner ("Keiro.Command"), event 'Codec's -("Keiro.Codec"), the 'EventStream' definition and its snapshot policy -("Keiro.EventStream"), the content-based 'Router' ("Keiro.Router"), -snapshot helpers ("Keiro.Snapshot"), and typed 'Stream' handles -("Keiro.Stream"). - -The more specialized subsystems are not re-exported here and are imported -directly when needed: read models ("Keiro.ReadModel"), projections -("Keiro.Projection"), process managers ("Keiro.ProcessManager"), the -integration in/outbox ("Keiro.Inbox", "Keiro.Outbox"), timers -("Keiro.Timer"), and telemetry ("Keiro.Telemetry"). - -Known limit: Keiro currently uses kiroku's PostgreSQL event store, whose append -path serializes all writers through the @$all@ stream row while assigning the -global event order. That makes the global position simple and deterministic, -but it is a throughput ceiling for very high write rates across many unrelated -streams. This production-readiness hardening pass documents the limit rather -than redesigning it; applications that outgrow the single-row global append -lock need a future event-store migration plan. --} -module Keiro ( - -- * Library version +-- | Umbrella entry point for the Keiro event-sourcing framework. +-- +-- Importing @Keiro@ brings the everyday command-side surface into scope in +-- one go: the command runner ("Keiro.Command"), event 'Codec's +-- ("Keiro.Codec"), the 'EventStream' definition and its snapshot policy +-- ("Keiro.EventStream"), the content-based 'Router' ("Keiro.Router"), +-- snapshot helpers ("Keiro.Snapshot"), and typed 'Stream' handles +-- ("Keiro.Stream"). +-- +-- The more specialized subsystems are not re-exported here and are imported +-- directly when needed: read models ("Keiro.ReadModel"), projections +-- ("Keiro.Projection"), process managers ("Keiro.ProcessManager"), the +-- integration in/outbox ("Keiro.Inbox", "Keiro.Outbox"), timers +-- ("Keiro.Timer"), and telemetry ("Keiro.Telemetry"). +-- +-- Known limit: Keiro currently uses kiroku's PostgreSQL event store, whose append +-- path serializes all writers through the @$all@ stream row while assigning the +-- global event order. That makes the global position simple and deterministic, +-- but it is a throughput ceiling for very high write rates across many unrelated +-- streams. This production-readiness hardening pass documents the limit rather +-- than redesigning it; applications that outgrow the single-row global append +-- lock need a future event-store migration plan. +module Keiro + ( -- * Library version version, -- * Command side @@ -40,7 +39,7 @@ -- * Routing and snapshots module Keiro.Router, module Keiro.Snapshot, -) + ) where import Keiro.Codec @@ -52,9 +51,8 @@ import Keiro.Snapshot import Keiro.Stream -{- | The Keiro library version, as a 'Text' for display and telemetry. -Keep in lockstep with the @version:@ field in @keiro/keiro.cabal@ when -cutting a release. --} +-- | The Keiro library version, as a 'Text' for display and telemetry. +-- Keep in lockstep with the @version:@ field in @keiro/keiro.cabal@ when +-- cutting a release. version :: Text version = "0.4.0.0" diff --git a/src/Keiro/Command.hs b/src/Keiro/Command.hs --- a/src/Keiro/Command.hs +++ b/src/Keiro/Command.hs @@ -1,1077 +1,1057 @@ -{- | The command side of the framework: hydrate an aggregate, transduce, append. - -Running a command against an 'EventStream' follows one pipeline: - -1. /Hydrate/ — replay the stream's stored events (optionally fast-forwarding - from a snapshot) through the keiki transducer to recover the current - @(state, registers)@ and stream version. -2. /Transduce/ — step the transducer with the command. A rejected transition - yields 'CommandRejected', while multiple matching transitions yield - 'CommandAmbiguous'; a transition that emits no events yields a no-op - 'CommandResult'. -3. /Append/ — encode the emitted events with the stream's 'Codec' and append - them at the expected version. An optimistic-concurrency conflict is - retried up to 'retryLimit' times by rehydrating and replaying; exhausting - the budget yields 'RetryExhausted'. - -Three runners expose this pipeline at increasing levels of integration: - -* 'runCommand' — append only. -* 'runCommandWithSql' — run an extra @afterAppend@ action in the /same/ - transaction as the append (e.g. update an inline read model). -* 'runCommandWithSqlEvents' — same, but the callback also receives the - emitted events paired with their 'RecordedEvent's. This is the primitive - the projection, process-manager, and router layers build on. - -The transactional runners apply Kiroku's configured @enrichEvent@ hook before -event preparation, exactly like 'runCommand'. They therefore require a -'KirokuStoreResource' in the effect stack; install it with @withKirokuStore@ -and interpret 'Store' with @runStoreResource@. - -Per-stream hydration honors Kiroku's stream-truncation marker. A retained -snapshot must cover every hidden event (snapshot version at least marker minus -one); otherwise hydration fails with 'HydrationGapDetected'. A marker above -the stream head can instead appear as an empty stream and repeated append -conflicts end in 'ConflictFixpoint'. Keiro never truncates streams itself. -Kiroku's @$all@ and category/subscription reads are unaffected by per-stream -truncation: the marker hides events from stream reads rather than deleting -them from the global log. - -Every successful append is replayed immediately from its pre-command state so -an unreplayable batch is witnessed at the moment it poisons the stream. The -post-commit witness is counted and attached to the command span without -changing the successful result. The same replay fold feeds transparent -snapshot writes when the stream's 'Keiro.EventStream.SnapshotPolicy' fires; -post-commit snapshot failures are likewise swallowed and counted. Every runner -accepts a tracer for optional OpenTelemetry spans. - -The additive hydration primitives are also consumed by "Keiro.ReplayAudit". -The audit deliberately calls the seeded and full variants separately so the -public command-serving fallback cannot hide a stale or unreplayable seed. --} -module Keiro.Command ( - -- * Results and errors - CommandResult (..), - CommandError (..), - HydrationReplayReason (..), - commandErrorClass, - - -- * Options - RunCommandOptions (..), - defaultRunCommandOptions, - - -- * Running commands - runCommand, - runCommandWithSql, - runCommandWithSqlEvents, - - -- * Hydration primitives (replay audit) - Hydrated (..), - hydrate, - hydrateFull, - hydrateSeeded, -) -where - -import Control.Concurrent (threadDelay) -import Control.Exception (displayException) -import Data.Aeson qualified as Aeson -import Data.ByteString.Lazy.Char8 qualified as LazyByteString -import Data.Functor (($>)) -import Data.Int (Int32) -import Data.Text qualified as Text -import Effectful (Eff, IOE, (:>)) -import Effectful.Concurrent (runConcurrent) -import Effectful.Concurrent.Async qualified as Async -import Effectful.Error.Static (Error, tryError) -import Effectful.Exception (trySync) -import GHC.Clock (getMonotonicTimeNSec) -import GHC.Stack (HasCallStack) -import Keiki.Core (BoolAlg, RegFile) -import Keiki.Core qualified as Keiki -import Keiro.Codec (Codec, CodecError, decodeRecorded, encodeForAppendWithMetadata) -import Keiro.EventStream (EventStream, StateCodec, Terminality (..)) -import Keiro.EventStream.Validate (ValidatedEventStream, unvalidated) -import Keiro.Prelude -import Keiro.ReplayDigest (canonicalJsonBytes, replayDigest) -import Keiro.Snapshot ( - SnapshotLookup (..), - SnapshotMissReason (..), - SnapshotSeed, - encodeSnapshotStrict, - lookupSnapshotSeed, - writeSnapshotEncoded, - ) -import Keiro.Snapshot.Policy (shouldSnapshotSpan) -import Keiro.Stream (Stream) -import Keiro.Telemetry ( - KeiroMetrics, - keiro_events_appended, - keiro_replay_divergence, - keiro_retry_attempt, - recordCommandConflicts, - recordCommandDuplicates, - recordCommandRetries, - recordSnapshotApplyDivergence, - recordSnapshotDecodeFailures, - recordSnapshotEncodeFailures, - recordSnapshotReadHits, - recordSnapshotReadMisses, - recordSnapshotSeedDivergence, - recordSnapshotWriteFailures, - withCommandSpan, - ) -import Kiroku.Store.Append (appendToStream) -import Kiroku.Store.Effect (Store) -import Kiroku.Store.Effect.Resource (KirokuStoreResource, getKirokuStore) -import Kiroku.Store.Error (StoreError (..)) -import Kiroku.Store.Read (readStreamForwardStream) -import Kiroku.Store.Transaction ( - PreparedEvent, - appendConflictToStoreError, - appendToStreamTx, - enrichEventsIO, - prepareEventsIO, - runTransaction, - ) -import Kiroku.Store.Types ( - AppendResult, - EventData, - EventId (..), - ExpectedVersion (..), - GlobalPosition (..), - RecordedEvent (..), - StreamName (..), - StreamVersion (..), - ) -import OpenTelemetry.Attributes.Key (unkey) -import OpenTelemetry.SemanticConventions (db_system_name, error_type) -import OpenTelemetry.Trace.Core (Span, SpanStatus (..), Tracer, addAttribute, setStatus) -import Streamly.Data.Fold qualified as Fold -import Streamly.Data.Stream qualified as Streamly -import System.IO (stderr) -import System.Random.Stateful (globalStdGen, uniformRM) -import "hasql-transaction" Hasql.Transaction qualified as Tx -import Prelude qualified - -{- | The outcome of a successfully handled command. - -Reports the target 'Stream', the stream version after the command, the global -log position only when this command appended and the store assigned a real -one, and how many events were appended. A no-op reports @0@ events and -@Nothing@ for its global position because per-stream reads cannot recover a -true global position. --} -data CommandResult target = CommandResult - { target :: !(Stream target) - , streamVersion :: !StreamVersion - , globalPosition :: !(Maybe GlobalPosition) - -- ^ 'Just' only when this command appended; 'Nothing' for a no-op. - , eventsAppended :: !Int - } - deriving stock (Generic, Eq, Show) - --- | Why a command did not complete. -data CommandError - = -- | A stored event could not be decoded while rehydrating the aggregate. - HydrationDecodeFailed !CodecError - | {- | Replay of the stored events through the transducer stalled. The - version identifies the failing stored event; for - 'HydrationTruncatedChain' it identifies the last stored event, after - which the expected multi-event chain remained incomplete. - -} - HydrationReplayFailed !StreamVersion !HydrationReplayReason - | {- | Hydration observed a non-contiguous stream version. Carries the - expected version followed by the observed version. The store writes - contiguous versions, so this indicates that stream truncation hid - events not covered by the hydration seed. Restore visibility with - @clearStreamTruncateBefore@ or provide a covering snapshot before - retrying the command. - -} - HydrationGapDetected !StreamVersion !StreamVersion - | -- | No transducer edge matched the command in the hydrated state. - CommandRejected - | {- | Two or more transducer edges matched the command in the hydrated - state. This is a deterministic aggregate-definition bug rather than a - business rejection; the list contains the zero-based matched edge - indices in declaration order. - -} - CommandAmbiguous ![Int] - | -- | An emitted event could not be encoded for append. - EncodeFailed !CodecError - | -- | The underlying store rejected the append. - StoreFailed !StoreError - | {- | Optimistic-concurrency retries were exhausted (carries the total - attempts made and the last store error). - -} - RetryExhausted !Int !StoreError - | {- | Retrying after a 'StreamAlreadyExists' conflict re-observed the same - stream version: the store says the stream exists but reading it shows no - progress. The typical cause is a soft-deleted stream, where reads return - nothing but appends still collide. Carries the observed version and the - conflict. - -} - ConflictFixpoint !StreamVersion !StoreError - deriving stock (Generic, Eq, Show) - -{- | Why replay of stored events stalled, projected from keiki's structured -failure types onto a monomorphic vocabulary suitable for 'CommandError'. --} -data HydrationReplayReason - = -- | No edge's first output template could have produced the event. - HydrationNoInvertingEdge - | -- | More than one edge could have produced the event. - HydrationAmbiguousInversion - | -- | An event did not match the next expected event in a chain. - HydrationQueueMismatch - | -- | The stream ended in the middle of a multi-event chain. - HydrationTruncatedChain - deriving stock (Generic, Eq, Show) - -{- | Knobs controlling a single command invocation. - -* 'retryLimit' — how many times to rehydrate-and-replay after an - optimistic-concurrency conflict before giving up with 'RetryExhausted'. -* 'pageSize' — batch size when reading the stream during hydration. -* 'eventIds' — caller-supplied ids assigned to the emitted events in order; - the basis for deterministic, idempotent appends (see 'Keiro.Router' and - 'Keiro.ProcessManager'). -* 'beforeAppend' — a hook run immediately before each append attempt, - primarily a test seam for injecting concurrent writes. -* 'retryBackoffMicros' — base delay before the k-th OCC retry, capped at - 100 ms and jittered. Set to 0 to disable backoff. -* 'metrics' — optional metrics handle for command and snapshot counters. -* 'verifyReplayOnAppend' — replay every just-appended batch from the - pre-command state. Divergence is a post-commit advisory: it is counted and - attached to the command span, but the already-successful command still - succeeds. Snapshot-enabled streams always run the fold because snapshots - consume its result. -* 'seedVerifySampleRate' — verify one in N snapshot seeds against a full - replay through the seed version. The replay runs asynchronously and never - blocks or fails the command. This detects hand-written fold changes that - leave the snapshot discriminator unchanged; @0@ disables the witness. --} -data RunCommandOptions = RunCommandOptions - { retryLimit :: !Int - , pageSize :: !Int32 - , eventIds :: ![EventId] - , beforeAppend :: !(IO ()) - , retryBackoffMicros :: !Int - , metrics :: !(Maybe KeiroMetrics) - , verifyReplayOnAppend :: !Bool - , seedVerifySampleRate :: !Int - , tracer :: !(Maybe Tracer) - {- ^ Optional OpenTelemetry tracer. When 'Just', the command runner - opens an 'Internal'-kind span around each invocation, named after - the resolved stream identifier and decorated with the messaging / - error semantic-conventions attributes audited in - 'docs/research/opentelemetry-semconv-audit.md'. When 'Nothing', - the runner emits no spans. - -} - , metadata :: !(Maybe Value) - {- ^ Optional JSON merged into every event's metadata for this command - invocation. Carries ambient context such as actor type, agent id, - and session id. The codec always adds a @schemaVersion@ key; the - keys here are merged on top (see 'Keiro.Codec.metadataFor'). When - 'Nothing', events carry only the schema-version marker, exactly as - before this field existed. - -} - } - deriving stock (Generic) - -{- | Sensible defaults: 3 retries, 256-event read pages, no caller-assigned -event ids, a no-op pre-append hook, 5ms retry backoff, no metrics, post-append -replay verification enabled, one sampled snapshot-seed verification per 1000 -snapshot hits, no tracer, and no extra metadata. --} -defaultRunCommandOptions :: RunCommandOptions -defaultRunCommandOptions = - RunCommandOptions - { retryLimit = 3 - , pageSize = 256 - , eventIds = [] - , beforeAppend = pure () - , retryBackoffMicros = 5000 - , metrics = Nothing - , verifyReplayOnAppend = True - , seedVerifySampleRate = 1000 - , tracer = Nothing - , metadata = Nothing - } - -data Hydrated rs s = Hydrated - { state :: !s - , registers :: !(RegFile rs) - , streamVersion :: !StreamVersion - } - deriving stock (Generic) - -data CommandPlan target rs s co - = CommandNoOp !(CommandResult target) - | CommandAppend !(Hydrated rs s) ![co] ![EventData] - deriving stock (Generic) - -hydrate :: - forall phi rs s ci co es. - (HasCallStack, IOE :> es, Store :> es, BoolAlg phi (RegFile rs, ci), Eq co) => - RunCommandOptions -> - EventStream phi rs s ci co -> - Stream (EventStream phi rs s ci co) -> - Eff es (Either CommandError (Hydrated rs s)) -hydrate options eventStream targetStream = - snapshotSeed >>= \case - Nothing -> hydrateFull options eventStream targetStream - Just seed -> do - replayed <- - hydrateSeeded - options - eventStream - targetStream - (seed ^. #state) - (seed ^. #registers) - (seed ^. #streamVersion) - case replayed of - Left _ -> hydrateFull options eventStream targetStream - Right hydrated -> do - for_ (eventStream ^. #stateCodec) $ \codec -> - scheduleSeedVerification options eventStream targetStream codec seed - pure (Right hydrated) - where - snapshotSeed = - case eventStream ^. #stateCodec of - Nothing -> pure Nothing - Just codec -> do - lookupSnapshotSeed ((eventStream ^. #resolveStreamName) targetStream) codec >>= \case - SnapshotHit seed -> do - recordSnapshotReadHits (options ^. #metrics) 1 - pure (Just seed) - SnapshotUnavailable reason -> do - recordSnapshotReadMisses (options ^. #metrics) 1 - case reason of - SnapshotDecodeFailed _ -> recordSnapshotDecodeFailures (options ^. #metrics) 1 - _ -> pure () - pure Nothing - -hydrateFull :: - forall phi rs s ci co es. - (HasCallStack, Store :> es, BoolAlg phi (RegFile rs, ci), Eq co) => - RunCommandOptions -> - EventStream phi rs s ci co -> - Stream (EventStream phi rs s ci co) -> - Eff es (Either CommandError (Hydrated rs s)) -hydrateFull options eventStream targetStream = - hydrateSeeded - options - eventStream - targetStream - (eventStream ^. #initialState) - (eventStream ^. #initialRegisters) - (StreamVersion 0) - -{- | Replay a stored stream from an arbitrary snapshot or initial-state seed. - -The store stream is grouped into bounded lists and each decoded prefix is -handed to keiki's 'Keiki.replayEvents'. Decoding stops at the first bad event in -a group, but the valid prefix is replayed first so an earlier replay failure -retains precedence over a later codec failure. --} -hydrateSeeded :: - forall phi rs s ci co es. - (HasCallStack, Store :> es, BoolAlg phi (RegFile rs, ci), Eq co) => - RunCommandOptions -> - EventStream phi rs s ci co -> - Stream (EventStream phi rs s ci co) -> - s -> - RegFile rs -> - StreamVersion -> - Eff es (Either CommandError (Hydrated rs s)) -hydrateSeeded options eventStream targetStream seedState seedRegisters seedVersion = do - hydrateSeededThrough - Nothing - options - eventStream - targetStream - seedState - seedRegisters - seedVersion - -hydrateSeededThrough :: - forall phi rs s ci co es. - (HasCallStack, Store :> es, BoolAlg phi (RegFile rs, ci), Eq co) => - Maybe StreamVersion -> - RunCommandOptions -> - EventStream phi rs s ci co -> - Stream (EventStream phi rs s ci co) -> - s -> - RegFile rs -> - StreamVersion -> - Eff es (Either CommandError (Hydrated rs s)) -hydrateSeededThrough replayThrough options eventStream targetStream seedState seedRegisters seedVersion = do - replayed <- - Streamly.fold - (Fold.foldlM' replayPage (pure (Right initialReplay))) - recordedPages - pure (finishReplay replayed) - where - readPageSize = Prelude.max 1 (options ^. #pageSize) - groupSize = Prelude.fromIntegral readPageSize - recordedPages = - Streamly.foldMany - (Fold.take groupSize Fold.toList) - boundedRecorded - boundedRecorded = - case replayThrough of - Nothing -> readStreamForwardStream resolvedName seedVersion readPageSize - Just endVersion -> - Streamly.takeWhile - (\recorded -> recorded ^. #streamVersion <= endVersion) - (readStreamForwardStream resolvedName seedVersion readPageSize) - resolvedName = (eventStream ^. #resolveStreamName) targetStream - initialReplay = (Keiki.Settled seedState, seedRegisters, Nothing) - - replayPage :: - Either CommandError (Keiki.InFlight s co, RegFile rs, Maybe RecordedEvent) -> - [RecordedEvent] -> - Eff es (Either CommandError (Keiki.InFlight s co, RegFile rs, Maybe RecordedEvent)) - replayPage (Left err) _ = pure (Left err) - replayPage (Right (wrapper, registers, previousRecorded)) page = - pure $ case Keiki.replayEvents (eventStream ^. #transducer) (wrapper, registers) decodedEvents of - Left replayFailure -> - Left (hydrationReplayError previousRecorded decodedRecorded replayFailure) - Right (nextWrapper, nextRegisters) -> - case pendingInputFailure of - Just err -> Left err - Nothing -> - Right - ( nextWrapper - , nextRegisters - , latestRecorded decodedRecorded previousRecorded - ) - where - (decodedRecorded, decodedEvents, pendingInputFailure) = decodePrefix previousRecorded page - - decodePrefix :: Maybe RecordedEvent -> [RecordedEvent] -> ([RecordedEvent], [co], Maybe CommandError) - decodePrefix previousRecorded = go [] [] startingVersion - where - startingVersion = maybe seedVersion (^. #streamVersion) previousRecorded - - go recordedAcc eventAcc lastSeen = \case - [] -> (Prelude.reverse recordedAcc, Prelude.reverse eventAcc, Nothing) - recorded : rest -> - let observed = recorded ^. #streamVersion - expected = nextStreamVersion lastSeen - in if observed /= expected - then - ( Prelude.reverse recordedAcc - , Prelude.reverse eventAcc - , Just (HydrationGapDetected expected observed) - ) - else case decodeRecorded (eventStream ^. #eventCodec) recorded of - Left err -> - ( Prelude.reverse recordedAcc - , Prelude.reverse eventAcc - , Just (HydrationDecodeFailed err) - ) - Right event -> - go (recorded : recordedAcc) (event : eventAcc) observed rest - - nextStreamVersion (StreamVersion version) = StreamVersion (version Prelude.+ 1) - - hydrationReplayError :: - Maybe RecordedEvent -> - [RecordedEvent] -> - Keiki.ReplayFailure s co -> - CommandError - hydrationReplayError previousRecorded decodedRecorded replayFailure = - HydrationReplayFailed failureVersion (toHydrationReason (Keiki.replayFailureReason replayFailure)) - where - failureVersion = - maybe seedVersion (^. #streamVersion) failureRecorded - failureRecorded = - case Keiki.replayFailureReason replayFailure of - Keiki.ReplayLogTruncated{} -> latestRecorded decodedRecorded previousRecorded - Keiki.ReplayEventFailed{} -> - case recordedAt (Keiki.replayFailedIndex replayFailure) decodedRecorded of - Just recorded -> Just recorded - Nothing -> latestRecorded decodedRecorded previousRecorded - - finishReplay = \case - Left err -> Left err - Right (wrapper, finalRegisters, lastRecorded) -> - case wrapper of - Keiki.Settled finalState -> - Right - Hydrated - { state = finalState - , registers = finalRegisters - , streamVersion = maybe seedVersion (^. #streamVersion) lastRecorded - } - Keiki.InFlight{} -> - Left - ( HydrationReplayFailed - (maybe seedVersion (^. #streamVersion) lastRecorded) - HydrationTruncatedChain - ) - - toHydrationReason = \case - Keiki.ReplayEventFailed stepFailure -> case stepFailure of - Keiki.ReplayNoInvertingEdge{} -> HydrationNoInvertingEdge - Keiki.ReplayAmbiguousInversions{} -> HydrationAmbiguousInversion - Keiki.ReplayQueueMismatch{} -> HydrationQueueMismatch - Keiki.ReplayLogTruncated{} -> HydrationTruncatedChain - - latestRecorded recorded fallback = - case lastMaybe recorded of - Just latest -> Just latest - Nothing -> fallback - - lastMaybe = \case - [] -> Nothing - first : rest -> Just (Prelude.foldl (\_ current -> current) first rest) - - recordedAt eventIndex recorded = - case Prelude.drop eventIndex recorded of - found : _ -> Just found - [] -> Nothing - -scheduleSeedVerification :: - forall phi rs s ci co es. - (HasCallStack, IOE :> es, Store :> es, BoolAlg phi (RegFile rs, ci), Eq co) => - RunCommandOptions -> - EventStream phi rs s ci co -> - Stream (EventStream phi rs s ci co) -> - StateCodec (s, RegFile rs) -> - SnapshotSeed rs s -> - Eff es () -scheduleSeedVerification options eventStream targetStream codec seed = do - void $ trySync $ do - sampled <- - case options ^. #seedVerifySampleRate of - rate | rate <= 0 -> pure False - 1 -> pure True - rate -> liftIO ((== (1 :: Int)) <$> uniformRM (1, rate) globalStdGen) - when sampled - $ void - $ runConcurrent - $ Async.async - $ verifySnapshotSeed options eventStream targetStream codec seed - -verifySnapshotSeed :: - forall phi rs s ci co es. - (HasCallStack, IOE :> es, Store :> es, BoolAlg phi (RegFile rs, ci), Eq co) => - RunCommandOptions -> - EventStream phi rs s ci co -> - Stream (EventStream phi rs s ci co) -> - StateCodec (s, RegFile rs) -> - SnapshotSeed rs s -> - Eff es () -verifySnapshotSeed options eventStream targetStream codec seed = do - let seedVersion = seed ^. #streamVersion - streamName = (eventStream ^. #resolveStreamName) targetStream - full <- - hydrateSeededThrough - (Just seedVersion) - options - eventStream - targetStream - (eventStream ^. #initialState) - (eventStream ^. #initialRegisters) - (StreamVersion 0) - seededEncoded <- - liftIO - $ encodeSnapshotStrict - codec - (seed ^. #state, seed ^. #registers) - case (seededEncoded, full) of - (Left seedEncodeError, _) -> - reportSeedDivergence - options - streamName - seedVersion - ("encode-failed:" <> Text.pack (displayException seedEncodeError)) - (case full of Left replayError -> "replay-failed:" <> Text.pack (show replayError); Right _ -> "not-compared:seed-encode-failed") - (Right seededValue, Left replayError) -> - reportSeedDivergence - options - streamName - seedVersion - (replayDigest seededValue) - ("replay-failed:" <> Text.pack (show replayError)) - (Right seededValue, Right fullHydrated) - | fullHydrated ^. #streamVersion /= seedVersion -> - reportSeedDivergence - options - streamName - seedVersion - (replayDigest seededValue) - ("version-mismatch:" <> Text.pack (show (fullHydrated ^. #streamVersion))) - | otherwise -> do - fullEncoded <- - liftIO - $ encodeSnapshotStrict - codec - (fullHydrated ^. #state, fullHydrated ^. #registers) - case fullEncoded of - Left fullEncodeError -> - reportSeedDivergence - options - streamName - seedVersion - (replayDigest seededValue) - ("encode-failed:" <> Text.pack (displayException fullEncodeError)) - Right fullValue -> - unless - (canonicalJsonBytes seededValue == canonicalJsonBytes fullValue) - ( reportSeedDivergence - options - streamName - seedVersion - (replayDigest seededValue) - (replayDigest fullValue) - ) - -reportSeedDivergence :: - (IOE :> es) => - RunCommandOptions -> - StreamName -> - StreamVersion -> - Text -> - Text -> - Eff es () -reportSeedDivergence options (StreamName streamName) (StreamVersion seedVersion) seededDigest fullDigest = do - recordSnapshotSeedDivergence (options ^. #metrics) 1 - liftIO - $ LazyByteString.hPutStrLn stderr - $ Aeson.encode - $ Aeson.object - [ "event" Aeson..= ("keiro.snapshot.seed.divergence" :: Text) - , "level" Aeson..= ("error" :: Text) - , "stream" Aeson..= streamName - , "seedVersion" Aeson..= seedVersion - , "seededDigest" Aeson..= seededDigest - , "fullDigest" Aeson..= fullDigest - ] - -{- | Hydrate the target stream, transduce the command, and append any emitted -events. Retries optimistic-concurrency conflicts up to 'retryLimit'. This -is the plain runner with no in-transaction side effects. --} -runCommand :: - forall phi rs s ci co es. - (HasCallStack, IOE :> es, Store :> es, Error StoreError :> es, BoolAlg phi (RegFile rs, ci), Eq co) => - RunCommandOptions -> - ValidatedEventStream phi rs s ci co -> - Stream (EventStream phi rs s ci co) -> - ci -> - Eff es (Either CommandError (CommandResult (EventStream phi rs s ci co))) -runCommand options validatedEventStream targetStream command = - withCommandSpan (options ^. #tracer) (resolvedStreamName eventStream targetStream) Nothing $ \mSpan -> do - (result, attemptNo) <- attempt mSpan 1 Nothing - recordCommandOutcome mSpan (^. #eventsAppended) attemptNo result - pure result - where - eventStream = unvalidated validatedEventStream - - attempt mSpan attemptNo lastConflict = do - hydrated <- hydrate options eventStream targetStream - either (\err -> pure (Left err, attemptNo)) (runPlan mSpan attemptNo lastConflict) hydrated - - runPlan mSpan attemptNo lastConflict current = - case conflictFixpoint lastConflict (current ^. #streamVersion) of - Just err -> pure (Left err, attemptNo) - Nothing -> - case prepareCommandPlan options eventStream targetStream current command of - Left err -> pure (Left err, attemptNo) - Right (CommandNoOp result) -> pure (Right result, attemptNo) - Right (CommandAppend current' events encoded) -> - appendOnce mSpan attemptNo current' events encoded - - appendOnce mSpan attemptNo current events encoded = do - liftIO (options ^. #beforeAppend) - appended <- - tryError @StoreError - $ appendToStream - ((eventStream ^. #resolveStreamName) targetStream) - (expectedVersion (current ^. #streamVersion)) - encoded - case appended of - Right appendResult -> do - verifyAndSnapshot options mSpan eventStream current events appendResult - pure (Right (appendedResult targetStream appendResult (Prelude.length encoded)), attemptNo) - Left (_, storeError) -> - retryOrFail options (attempt mSpan) attemptNo (current ^. #streamVersion) storeError - -{- | Like 'runCommand', but run @afterAppend@ inside the /same/ transaction -as the append, so a read-model write commits atomically with the events. -The callback's result is returned as @Just@ on append (and 'Nothing' for a -no-op command that appended nothing). - -Requires 'KirokuStoreResource' so the transactional append applies the -configured @enrichEvent@ hook. See 'runCommandWithSqlEvents' for the callback's -locking and latency implications. --} -runCommandWithSql :: - forall phi rs s ci co a es. - (HasCallStack, IOE :> es, Store :> es, Error StoreError :> es, KirokuStoreResource :> es, BoolAlg phi (RegFile rs, ci), Eq co) => - RunCommandOptions -> - ValidatedEventStream phi rs s ci co -> - Stream (EventStream phi rs s ci co) -> - ci -> - (AppendResult -> Tx.Transaction a) -> - Eff es (Either CommandError (CommandResult (EventStream phi rs s ci co), Maybe a)) -runCommandWithSql options eventStream targetStream command afterAppend = - runCommandWithSqlEvents options eventStream targetStream command (\_ appendResult -> afterAppend appendResult) - -{- | The most general runner: like 'runCommandWithSql', but the -in-transaction callback also receives every emitted event paired with the -'RecordedEvent' the store persisted for it, in append order. Inline -projections, process managers, and routers are all built on this. - -The runner requires 'KirokuStoreResource' and applies the configured -@enrichEvent@ hook before preparing the append. The callback therefore sees -the enriched metadata that was persisted. - -The append updates Kiroku's global @$all@ stream and holds its PostgreSQL row -lock until this transaction commits. Every SQL operation in the callback -therefore extends the store-wide append serialization window. Keep the -callback small: precompute outside the transaction where possible, batch -writes, and minimize database round trips. --} -runCommandWithSqlEvents :: - forall phi rs s ci co a es. - (HasCallStack, IOE :> es, Store :> es, Error StoreError :> es, KirokuStoreResource :> es, BoolAlg phi (RegFile rs, ci), Eq co) => - RunCommandOptions -> - ValidatedEventStream phi rs s ci co -> - Stream (EventStream phi rs s ci co) -> - ci -> - ([(co, RecordedEvent)] -> AppendResult -> Tx.Transaction a) -> - Eff es (Either CommandError (CommandResult (EventStream phi rs s ci co), Maybe a)) -runCommandWithSqlEvents options validatedEventStream targetStream command afterAppend = - withCommandSpan (options ^. #tracer) (resolvedStreamName eventStream targetStream) Nothing $ \mSpan -> do - (result, attemptNo) <- attempt mSpan 1 Nothing - recordCommandOutcome mSpan (\(r, _) -> r ^. #eventsAppended) attemptNo result - pure result - where - eventStream = unvalidated validatedEventStream - - attempt mSpan attemptNo lastConflict = do - hydrated <- hydrate options eventStream targetStream - either (\err -> pure (Left err, attemptNo)) (runPlan mSpan attemptNo lastConflict) hydrated - - runPlan mSpan attemptNo lastConflict current = - case conflictFixpoint lastConflict (current ^. #streamVersion) of - Just err -> pure (Left err, attemptNo) - Nothing -> - case prepareCommandPlan options eventStream targetStream current command of - Left err -> pure (Left err, attemptNo) - Right (CommandNoOp result) -> pure (Right (result, Nothing), attemptNo) - Right (CommandAppend current' events encoded) -> - appendWithSqlOnce mSpan attemptNo current' events encoded - - appendWithSqlOnce mSpan attemptNo current events encoded = do - liftIO (options ^. #beforeAppend) - store <- getKirokuStore - enriched <- liftIO (enrichEventsIO store encoded) - prepared <- prepareEventsIO enriched - now <- liftIO getCurrentTime - let streamName = (eventStream ^. #resolveStreamName) targetStream - expected = expectedVersion (current ^. #streamVersion) - body = do - appended <- appendToStreamTx streamName expected prepared now - case appended of - Left conflict -> - Tx.condemn $> Left (appendConflictToStoreError conflict) - Right appendResult -> do - let recordeds = reconstructRecorded appendResult now prepared - userValue <- afterAppend (Prelude.zip events recordeds) appendResult - pure (Right (appendResult, userValue)) - outcome <- tryError @StoreError (runTransaction body) - case outcome of - Right (Right (appendResult, userValue)) -> do - verifyAndSnapshot options mSpan eventStream current events appendResult - pure (Right (appendedResult targetStream appendResult (Prelude.length encoded), Just userValue), attemptNo) - Right (Left storeError) -> - retryOrFail options (attempt mSpan) attemptNo (current ^. #streamVersion) storeError - Left (_, storeError) -> - retryOrFail options (attempt mSpan) attemptNo (current ^. #streamVersion) storeError - -prepareCommandPlan :: - (BoolAlg phi (RegFile rs, ci)) => - RunCommandOptions -> - EventStream phi rs s ci co -> - Stream (EventStream phi rs s ci co) -> - Hydrated rs s -> - ci -> - Either CommandError (CommandPlan (EventStream phi rs s ci co) rs s co) -prepareCommandPlan options eventStream targetStream current command = - case evaluateCommand eventStream current command of - Left err -> Left err - Right events -> toPlan events - where - toPlan [] = - Right (CommandNoOp (noOpResult targetStream current)) - toPlan events = - CommandAppend current events - . assignEventIds (options ^. #eventIds) - <$> encodeEvents (eventStream ^. #eventCodec) (options ^. #metadata) events - -{- | Render the stream that the command targets as plain 'Text', for use -as a span name. --} -resolvedStreamName :: - EventStream phi rs s ci co -> - Stream (EventStream phi rs s ci co) -> - Text -resolvedStreamName eventStream targetStream = - case (eventStream ^. #resolveStreamName) targetStream of - StreamName n -> n - -{- | Attach the command-span outcome attributes after the runner returns. - -On success: 'db.system.name' and 'keiro.events.appended'. -On failure: 'error.type' (low-cardinality classifier) and span status -'Error' (carrying the rendered 'CommandError' as the description). - -Pure no-op when no span is active ('Nothing' tracer, etc). --} -recordCommandOutcome :: - (IOE :> es) => - Maybe Span -> - (a -> Int) -> - Int -> - Either CommandError a -> - Eff es () -recordCommandOutcome Nothing _ _ _ = pure () -recordCommandOutcome (Just sp) eventsOf attemptNo result = do - addAttribute sp (unkey db_system_name) ("postgresql" :: Text) - addAttribute sp (unkey keiro_retry_attempt) (Prelude.fromIntegral attemptNo :: Int64) - case result of - Right v -> - addAttribute sp (unkey keiro_events_appended) (Prelude.fromIntegral (eventsOf v) :: Int64) - Left err -> do - addAttribute sp (unkey error_type) (commandErrorClass err) - setStatus sp (Error (Text.take 256 (Text.pack (show err)))) - -{- | Low-cardinality classifier for a 'CommandError'. Used as the -@error.type@ attribute value on the command span. --} -commandErrorClass :: CommandError -> Text -commandErrorClass = \case - HydrationDecodeFailed{} -> "hydration_decode_failed" - HydrationReplayFailed _ HydrationNoInvertingEdge -> "hydration_replay_no_inverting_edge" - HydrationReplayFailed _ HydrationAmbiguousInversion -> "hydration_replay_ambiguous_inversion" - HydrationReplayFailed _ HydrationQueueMismatch -> "hydration_replay_queue_mismatch" - HydrationReplayFailed _ HydrationTruncatedChain -> "hydration_replay_truncated_chain" - HydrationGapDetected{} -> "hydration_gap_detected" - CommandRejected -> "command_rejected" - CommandAmbiguous{} -> "command_ambiguous" - EncodeFailed{} -> "encode_failed" - StoreFailed{} -> "store_failed" - RetryExhausted{} -> "retry_exhausted" - ConflictFixpoint{} -> "conflict_fixpoint" - -verifyAndSnapshot :: - forall phi rs s ci co es. - (BoolAlg phi (RegFile rs, ci), IOE :> es, Store :> es, Error StoreError :> es, Eq co) => - RunCommandOptions -> - Maybe Span -> - EventStream phi rs s ci co -> - Hydrated rs s -> - [co] -> - AppendResult -> - Eff es () -verifyAndSnapshot options mSpan eventStream current events appendResult - | Prelude.not (options ^. #verifyReplayOnAppend) - , Nothing <- eventStream ^. #stateCodec = - pure () - | otherwise = - case Keiki.applyEventsEither (eventStream ^. #transducer) (state current, registers current) events of - Left failure -> do - recordSnapshotApplyDivergence (options ^. #metrics) 1 - for_ mSpan $ \sp -> - addAttribute - sp - (unkey keiro_replay_divergence) - (Text.take 256 (renderReplayFailure failure)) - Right finalState -> - case eventStream ^. #stateCodec of - Nothing -> pure () - Just codec -> do - let finalVersion = appendResult ^. #streamVersion - terminality = - if Keiki.isFinal (eventStream ^. #transducer) (Prelude.fst finalState) - then Terminal - else NotTerminal - when (shouldSnapshotSpan (eventStream ^. #snapshotPolicy) terminality finalState (current ^. #streamVersion) finalVersion) - $ do - encoded <- liftIO (encodeSnapshotStrict codec finalState) - case encoded of - Left _ -> recordSnapshotEncodeFailures (options ^. #metrics) 1 - Right value -> do - outcome <- tryError @StoreError (writeSnapshotEncoded (appendResult ^. #streamId) finalVersion codec value) - case outcome of - Right () -> pure () - Left _ -> recordSnapshotWriteFailures (options ^. #metrics) 1 - -renderReplayFailure :: Keiki.ReplayFailure s co -> Text -renderReplayFailure failure = - "event_index=" - <> Text.pack (show (Keiki.replayFailedIndex failure)) - <> ";reason=" - <> case Keiki.replayFailureReason failure of - Keiki.ReplayEventFailed stepFailure -> case stepFailure of - Keiki.ReplayNoInvertingEdge{} -> "no_inverting_edge" - Keiki.ReplayAmbiguousInversions{} -> "ambiguous_inversions" - Keiki.ReplayQueueMismatch{} -> "queue_mismatch" - Keiki.ReplayLogTruncated{} -> "log_truncated" - -retryOrFail :: - (IOE :> es) => - RunCommandOptions -> - (Int -> Maybe (StoreError, StreamVersion) -> Eff es (Either CommandError a, Int)) -> - Int -> - StreamVersion -> - StoreError -> - Eff es (Either CommandError a, Int) -retryOrFail options retry attemptNo observedVersion storeError - | isRetryableConflict storeError - , attemptNo <= options ^. #retryLimit = do - recordCommandConflicts (options ^. #metrics) 1 - backoffDelay options attemptNo - recordCommandRetries (options ^. #metrics) 1 - retry (attemptNo Prelude.+ 1) (Just (storeError, observedVersion)) - | isRetryableConflict storeError = do - recordCommandConflicts (options ^. #metrics) 1 - pure (Left (RetryExhausted attemptNo storeError), attemptNo) - | otherwise = do - case storeError of - DuplicateEvent{} -> recordCommandDuplicates (options ^. #metrics) 1 - _ -> pure () - pure (Left (StoreFailed storeError), attemptNo) - -backoffDelay :: (IOE :> es) => RunCommandOptions -> Int -> Eff es () -backoffDelay options attemptNo - | base <= 0 = pure () - | otherwise = do - nanos <- liftIO getMonotonicTimeNSec - let exponential = min 100000 (base Prelude.* (2 Prelude.^ (attemptNo Prelude.- 1 :: Int))) - jitter = - Prelude.fromIntegral (nanos `Prelude.mod` Prelude.fromIntegral exponential) - Prelude.- (exponential `Prelude.div` 2) - liftIO (threadDelay (max 0 (exponential Prelude.+ jitter))) - where - base = options ^. #retryBackoffMicros - -conflictFixpoint :: Maybe (StoreError, StreamVersion) -> StreamVersion -> Maybe CommandError -conflictFixpoint (Just (previousError@StreamAlreadyExists{}, previousVersion)) currentVersion - | currentVersion == previousVersion = Just (ConflictFixpoint currentVersion previousError) -conflictFixpoint _ _ = Nothing - -evaluateCommand :: - (BoolAlg phi (RegFile rs, ci)) => - EventStream phi rs s ci co -> - Hydrated rs s -> - ci -> - Either CommandError [co] -evaluateCommand eventStream current command = - case Keiki.stepEither (eventStream ^. #transducer) (state current, registers current) command of - Left Keiki.NoOutgoingEdges{} -> Left CommandRejected - Left Keiki.NoMatchingEdge{} -> Left CommandRejected - Left (Keiki.AmbiguousEdges _ matches) -> - Left - ( CommandAmbiguous - [ Keiki.edgeIndex (Keiki.matchedEdge matched) - | matched <- matches - ] - ) - Right (_, _, events) -> Right events - -encodeEvents :: Codec co -> Maybe Value -> [co] -> Either CommandError [EventData] -encodeEvents codec md = - Prelude.mapM (mapLeft EncodeFailed . encodeForAppendWithMetadata codec md) - -assignEventIds :: [EventId] -> [EventData] -> [EventData] -assignEventIds [] events = events -assignEventIds _ [] = [] -assignEventIds (supplied : suppliedRest) (event : eventRest) = - (event & #eventId .~ Just supplied) : assignEventIds suppliedRest eventRest - -expectedVersion :: StreamVersion -> ExpectedVersion -expectedVersion (StreamVersion 0) = NoStream -expectedVersion version = ExactVersion version - -noOpResult :: - Stream target -> - Hydrated rs s -> - CommandResult target -noOpResult targetStream current = - CommandResult - { target = targetStream - , streamVersion = current ^. #streamVersion - , globalPosition = Nothing - , eventsAppended = 0 - } - -appendedResult :: - Stream target -> - AppendResult -> - Int -> - CommandResult target -appendedResult targetStream appendResult count = - CommandResult - { target = targetStream - , streamVersion = appendResult ^. #streamVersion - , globalPosition = Just (appendResult ^. #globalPosition) - , eventsAppended = count - } - -{- | Rebuild the per-event 'RecordedEvent' values for a just-appended batch. - -The store assigns each event in a batch a contiguous stream version and -global position: event @i@ (1-based) gets @last - count + i@ for both -counters, where @last@ is the position the 'AppendResult' reports for the -final event and @count@ is the batch size. (The kiroku append SQL numbers -events with @WITH ORDINALITY@ and inserts @initial + idx@; see EP-27's -Surprises & Discoveries.) We therefore reconstruct each 'RecordedEvent' -exactly, rather than reading the batch back. The @createdAt@ is the same -timestamp 'prepareEventsIO'/'appendToStreamTx' used for the insert. - -This is a source append (events are written to their own stream), so -@streamVersion == originalVersion@ and @originalStreamId@ is the appended -stream's id, per the 'RecordedEvent' contract. --} -reconstructRecorded :: AppendResult -> UTCTime -> [PreparedEvent] -> [RecordedEvent] -reconstructRecorded appendResult now prepared = - Prelude.zipWith mk [0 ..] prepared - where - count = Prelude.length prepared - StreamVersion lastSv = appendResult ^. #streamVersion - GlobalPosition lastGp = appendResult ^. #globalPosition - firstSv = lastSv Prelude.- Prelude.fromIntegral count Prelude.+ 1 - firstGp = lastGp Prelude.- Prelude.fromIntegral count Prelude.+ 1 - mk :: Int64 -> PreparedEvent -> RecordedEvent - mk i prepared' = - RecordedEvent - { eventId = EventId (prepared' ^. #peEventId) - , eventType = prepared' ^. #peEventType - , streamVersion = StreamVersion (firstSv Prelude.+ i) - , globalPosition = GlobalPosition (firstGp Prelude.+ i) - , originalStreamId = appendResult ^. #streamId - , originalVersion = StreamVersion (firstSv Prelude.+ i) - , payload = prepared' ^. #pePayload - , metadata = prepared' ^. #peMetadata - , causationId = prepared' ^. #peCausationId - , correlationId = prepared' ^. #peCorrelationId - , createdAt = now - } - -isRetryableConflict :: StoreError -> Bool -isRetryableConflict = \case - WrongExpectedVersion{} -> True - StreamAlreadyExists{} -> True - _ -> False - -mapLeft :: (e -> e') -> Either e a -> Either e' a -mapLeft f = \case - Left err -> Left (f err) - Right value -> Right value +-- | The command side of the framework: hydrate an aggregate, transduce, append. +-- +-- Running a command against an 'EventStream' follows one pipeline: +-- +-- 1. /Hydrate/ — replay the stream's stored events (optionally fast-forwarding +-- from a snapshot) through the keiki transducer to recover the current +-- @(state, registers)@ and stream version. +-- 2. /Transduce/ — step the transducer with the command. A rejected transition +-- yields 'CommandRejected', while multiple matching transitions yield +-- 'CommandAmbiguous'; a transition that emits no events yields a no-op +-- 'CommandResult'. +-- 3. /Append/ — encode the emitted events with the stream's 'Codec' and append +-- them at the expected version. An optimistic-concurrency conflict is +-- retried up to 'retryLimit' times by rehydrating and replaying; exhausting +-- the budget yields 'RetryExhausted'. +-- +-- Three runners expose this pipeline at increasing levels of integration: +-- +-- * 'runCommand' — append only. +-- * 'runCommandWithSql' — run an extra @afterAppend@ action in the /same/ +-- transaction as the append (e.g. update an inline read model). +-- * 'runCommandWithSqlEvents' — same, but the callback also receives the +-- emitted events paired with their 'RecordedEvent's. This is the primitive +-- the projection, process-manager, and router layers build on. +-- +-- The transactional runners apply Kiroku's configured @enrichEvent@ hook before +-- event preparation, exactly like 'runCommand'. They therefore require a +-- 'KirokuStoreResource' in the effect stack; install it with @withKirokuStore@ +-- and interpret 'Store' with @runStoreResource@. +-- +-- Per-stream hydration honors Kiroku's stream-truncation marker. A retained +-- snapshot must cover every hidden event (snapshot version at least marker minus +-- one); otherwise hydration fails with 'HydrationGapDetected'. A marker above +-- the stream head can instead appear as an empty stream and repeated append +-- conflicts end in 'ConflictFixpoint'. Keiro never truncates streams itself. +-- Kiroku's @$all@ and category/subscription reads are unaffected by per-stream +-- truncation: the marker hides events from stream reads rather than deleting +-- them from the global log. +-- +-- Every successful append is replayed immediately from its pre-command state so +-- an unreplayable batch is witnessed at the moment it poisons the stream. The +-- post-commit witness is counted and attached to the command span without +-- changing the successful result. The same replay fold feeds transparent +-- snapshot writes when the stream's 'Keiro.EventStream.SnapshotPolicy' fires; +-- post-commit snapshot failures are likewise swallowed and counted. Every runner +-- accepts a tracer for optional OpenTelemetry spans. +-- +-- The additive hydration primitives are also consumed by "Keiro.ReplayAudit". +-- The audit deliberately calls the seeded and full variants separately so the +-- public command-serving fallback cannot hide a stale or unreplayable seed. +module Keiro.Command + ( -- * Results and errors + CommandResult (..), + CommandError (..), + HydrationReplayReason (..), + commandErrorClass, + + -- * Options + RunCommandOptions (..), + defaultRunCommandOptions, + + -- * Running commands + runCommand, + runCommandWithSql, + runCommandWithSqlEvents, + + -- * Hydration primitives (replay audit) + Hydrated (..), + hydrate, + hydrateFull, + hydrateSeeded, + ) +where + +import Control.Concurrent (threadDelay) +import Control.Exception (displayException) +import Data.Aeson qualified as Aeson +import Data.ByteString.Lazy.Char8 qualified as LazyByteString +import Data.Functor (($>)) +import Data.Int (Int32) +import Data.Text qualified as Text +import Effectful (Eff, IOE, (:>)) +import Effectful.Concurrent (runConcurrent) +import Effectful.Concurrent.Async qualified as Async +import Effectful.Error.Static (Error, tryError) +import Effectful.Exception (trySync) +import GHC.Clock (getMonotonicTimeNSec) +import GHC.Stack (HasCallStack) +import Keiki.Core (BoolAlg, RegFile) +import Keiki.Core qualified as Keiki +import Keiro.Codec (Codec, CodecError, decodeRecorded, encodeForAppendWithMetadata) +import Keiro.EventStream (EventStream, StateCodec, Terminality (..)) +import Keiro.EventStream.Validate (ValidatedEventStream, unvalidated) +import Keiro.Prelude +import Keiro.ReplayDigest (canonicalJsonBytes, replayDigest) +import Keiro.Snapshot + ( SnapshotLookup (..), + SnapshotMissReason (..), + SnapshotSeed, + encodeSnapshotStrict, + lookupSnapshotSeed, + writeSnapshotEncoded, + ) +import Keiro.Snapshot.Policy (shouldSnapshotSpan) +import Keiro.Stream (Stream) +import Keiro.Telemetry + ( KeiroMetrics, + keiro_events_appended, + keiro_replay_divergence, + keiro_retry_attempt, + recordCommandConflicts, + recordCommandDuplicates, + recordCommandRetries, + recordSnapshotApplyDivergence, + recordSnapshotDecodeFailures, + recordSnapshotEncodeFailures, + recordSnapshotReadHits, + recordSnapshotReadMisses, + recordSnapshotSeedDivergence, + recordSnapshotWriteFailures, + withCommandSpan, + ) +import Kiroku.Store.Append (appendToStream) +import Kiroku.Store.Effect (Store) +import Kiroku.Store.Effect.Resource (KirokuStoreResource, getKirokuStore) +import Kiroku.Store.Error (StoreError (..)) +import Kiroku.Store.Read (readStreamForwardStream) +import Kiroku.Store.Transaction + ( PreparedEvent, + appendConflictToStoreError, + appendToStreamTx, + enrichEventsIO, + prepareEventsIO, + runTransaction, + ) +import Kiroku.Store.Types + ( AppendResult, + EventData, + EventId (..), + ExpectedVersion (..), + GlobalPosition (..), + RecordedEvent (..), + StreamName (..), + StreamVersion (..), + ) +import OpenTelemetry.Attributes.Key (unkey) +import OpenTelemetry.SemanticConventions (db_system_name, error_type) +import OpenTelemetry.Trace.Core (Span, SpanStatus (..), Tracer, addAttribute, setStatus) +import Streamly.Data.Fold qualified as Fold +import Streamly.Data.Stream qualified as Streamly +import System.IO (stderr) +import System.Random.Stateful (globalStdGen, uniformRM) +import "hasql-transaction" Hasql.Transaction qualified as Tx +import Prelude qualified + +-- | The outcome of a successfully handled command. +-- +-- Reports the target 'Stream', the stream version after the command, the global +-- log position only when this command appended and the store assigned a real +-- one, and how many events were appended. A no-op reports @0@ events and +-- @Nothing@ for its global position because per-stream reads cannot recover a +-- true global position. +data CommandResult target = CommandResult + { target :: !(Stream target), + streamVersion :: !StreamVersion, + -- | 'Just' only when this command appended; 'Nothing' for a no-op. + globalPosition :: !(Maybe GlobalPosition), + eventsAppended :: !Int + } + deriving stock (Generic, Eq, Show) + +-- | Why a command did not complete. +data CommandError + = -- | A stored event could not be decoded while rehydrating the aggregate. + HydrationDecodeFailed !CodecError + | -- | Replay of the stored events through the transducer stalled. The + -- version identifies the failing stored event; for + -- 'HydrationTruncatedChain' it identifies the last stored event, after + -- which the expected multi-event chain remained incomplete. + HydrationReplayFailed !StreamVersion !HydrationReplayReason + | -- | Hydration observed a non-contiguous stream version. Carries the + -- expected version followed by the observed version. The store writes + -- contiguous versions, so this indicates that stream truncation hid + -- events not covered by the hydration seed. Restore visibility with + -- @clearStreamTruncateBefore@ or provide a covering snapshot before + -- retrying the command. + HydrationGapDetected !StreamVersion !StreamVersion + | -- | No transducer edge matched the command in the hydrated state. + CommandRejected + | -- | Two or more transducer edges matched the command in the hydrated + -- state. This is a deterministic aggregate-definition bug rather than a + -- business rejection; the list contains the zero-based matched edge + -- indices in declaration order. + CommandAmbiguous ![Int] + | -- | An emitted event could not be encoded for append. + EncodeFailed !CodecError + | -- | The underlying store rejected the append. + StoreFailed !StoreError + | -- | Optimistic-concurrency retries were exhausted (carries the total + -- attempts made and the last store error). + RetryExhausted !Int !StoreError + | -- | Retrying after a 'StreamAlreadyExists' conflict re-observed the same + -- stream version: the store says the stream exists but reading it shows no + -- progress. The typical cause is a soft-deleted stream, where reads return + -- nothing but appends still collide. Carries the observed version and the + -- conflict. + ConflictFixpoint !StreamVersion !StoreError + deriving stock (Generic, Eq, Show) + +-- | Why replay of stored events stalled, projected from keiki's structured +-- failure types onto a monomorphic vocabulary suitable for 'CommandError'. +data HydrationReplayReason + = -- | No edge's first output template could have produced the event. + HydrationNoInvertingEdge + | -- | More than one edge could have produced the event. + HydrationAmbiguousInversion + | -- | An event did not match the next expected event in a chain. + HydrationQueueMismatch + | -- | The stream ended in the middle of a multi-event chain. + HydrationTruncatedChain + deriving stock (Generic, Eq, Show) + +-- | Knobs controlling a single command invocation. +-- +-- * 'retryLimit' — how many times to rehydrate-and-replay after an +-- optimistic-concurrency conflict before giving up with 'RetryExhausted'. +-- * 'pageSize' — batch size when reading the stream during hydration. +-- * 'eventIds' — caller-supplied ids assigned to the emitted events in order; +-- the basis for deterministic, idempotent appends (see 'Keiro.Router' and +-- 'Keiro.ProcessManager'). +-- * 'beforeAppend' — a hook run immediately before each append attempt, +-- primarily a test seam for injecting concurrent writes. +-- * 'retryBackoffMicros' — base delay before the k-th OCC retry, capped at +-- 100 ms and jittered. Set to 0 to disable backoff. +-- * 'metrics' — optional metrics handle for command and snapshot counters. +-- * 'verifyReplayOnAppend' — replay every just-appended batch from the +-- pre-command state. Divergence is a post-commit advisory: it is counted and +-- attached to the command span, but the already-successful command still +-- succeeds. Snapshot-enabled streams always run the fold because snapshots +-- consume its result. +-- * 'seedVerifySampleRate' — verify one in N snapshot seeds against a full +-- replay through the seed version. The replay runs asynchronously and never +-- blocks or fails the command. This detects hand-written fold changes that +-- leave the snapshot discriminator unchanged; @0@ disables the witness. +data RunCommandOptions = RunCommandOptions + { retryLimit :: !Int, + pageSize :: !Int32, + eventIds :: ![EventId], + beforeAppend :: !(IO ()), + retryBackoffMicros :: !Int, + metrics :: !(Maybe KeiroMetrics), + verifyReplayOnAppend :: !Bool, + seedVerifySampleRate :: !Int, + -- | Optional OpenTelemetry tracer. When 'Just', the command runner + -- opens an 'Internal'-kind span around each invocation, named after + -- the resolved stream identifier and decorated with the messaging / + -- error semantic-conventions attributes audited in + -- 'docs/research/opentelemetry-semconv-audit.md'. When 'Nothing', + -- the runner emits no spans. + tracer :: !(Maybe Tracer), + -- | Optional JSON merged into every event's metadata for this command + -- invocation. Carries ambient context such as actor type, agent id, + -- and session id. The codec always adds a @schemaVersion@ key; the + -- keys here are merged on top (see 'Keiro.Codec.metadataFor'). When + -- 'Nothing', events carry only the schema-version marker, exactly as + -- before this field existed. + metadata :: !(Maybe Value) + } + deriving stock (Generic) + +-- | Sensible defaults: 3 retries, 256-event read pages, no caller-assigned +-- event ids, a no-op pre-append hook, 5ms retry backoff, no metrics, post-append +-- replay verification enabled, one sampled snapshot-seed verification per 1000 +-- snapshot hits, no tracer, and no extra metadata. +defaultRunCommandOptions :: RunCommandOptions +defaultRunCommandOptions = + RunCommandOptions + { retryLimit = 3, + pageSize = 256, + eventIds = [], + beforeAppend = pure (), + retryBackoffMicros = 5000, + metrics = Nothing, + verifyReplayOnAppend = True, + seedVerifySampleRate = 1000, + tracer = Nothing, + metadata = Nothing + } + +data Hydrated rs s = Hydrated + { state :: !s, + registers :: !(RegFile rs), + streamVersion :: !StreamVersion + } + deriving stock (Generic) + +data CommandPlan target rs s co + = CommandNoOp !(CommandResult target) + | CommandAppend !(Hydrated rs s) ![co] ![EventData] + deriving stock (Generic) + +hydrate :: + forall phi rs s ci co es. + (HasCallStack, IOE :> es, Store :> es, BoolAlg phi (RegFile rs, ci), Eq co) => + RunCommandOptions -> + EventStream phi rs s ci co -> + Stream (EventStream phi rs s ci co) -> + Eff es (Either CommandError (Hydrated rs s)) +hydrate options eventStream targetStream = + snapshotSeed >>= \case + Nothing -> hydrateFull options eventStream targetStream + Just seed -> do + replayed <- + hydrateSeeded + options + eventStream + targetStream + (seed ^. #state) + (seed ^. #registers) + (seed ^. #streamVersion) + case replayed of + Left _ -> hydrateFull options eventStream targetStream + Right hydrated -> do + for_ (eventStream ^. #stateCodec) $ \codec -> + scheduleSeedVerification options eventStream targetStream codec seed + pure (Right hydrated) + where + snapshotSeed = + case eventStream ^. #stateCodec of + Nothing -> pure Nothing + Just codec -> do + lookupSnapshotSeed ((eventStream ^. #resolveStreamName) targetStream) codec >>= \case + SnapshotHit seed -> do + recordSnapshotReadHits (options ^. #metrics) 1 + pure (Just seed) + SnapshotUnavailable reason -> do + recordSnapshotReadMisses (options ^. #metrics) 1 + case reason of + SnapshotDecodeFailed _ -> recordSnapshotDecodeFailures (options ^. #metrics) 1 + _ -> pure () + pure Nothing + +hydrateFull :: + forall phi rs s ci co es. + (HasCallStack, Store :> es, BoolAlg phi (RegFile rs, ci), Eq co) => + RunCommandOptions -> + EventStream phi rs s ci co -> + Stream (EventStream phi rs s ci co) -> + Eff es (Either CommandError (Hydrated rs s)) +hydrateFull options eventStream targetStream = + hydrateSeeded + options + eventStream + targetStream + (eventStream ^. #initialState) + (eventStream ^. #initialRegisters) + (StreamVersion 0) + +-- | Replay a stored stream from an arbitrary snapshot or initial-state seed. +-- +-- The store stream is grouped into bounded lists and each decoded prefix is +-- handed to keiki's 'Keiki.replayEvents'. Decoding stops at the first bad event in +-- a group, but the valid prefix is replayed first so an earlier replay failure +-- retains precedence over a later codec failure. +hydrateSeeded :: + forall phi rs s ci co es. + (HasCallStack, Store :> es, BoolAlg phi (RegFile rs, ci), Eq co) => + RunCommandOptions -> + EventStream phi rs s ci co -> + Stream (EventStream phi rs s ci co) -> + s -> + RegFile rs -> + StreamVersion -> + Eff es (Either CommandError (Hydrated rs s)) +hydrateSeeded options eventStream targetStream seedState seedRegisters seedVersion = do + hydrateSeededThrough + Nothing + options + eventStream + targetStream + seedState + seedRegisters + seedVersion + +hydrateSeededThrough :: + forall phi rs s ci co es. + (HasCallStack, Store :> es, BoolAlg phi (RegFile rs, ci), Eq co) => + Maybe StreamVersion -> + RunCommandOptions -> + EventStream phi rs s ci co -> + Stream (EventStream phi rs s ci co) -> + s -> + RegFile rs -> + StreamVersion -> + Eff es (Either CommandError (Hydrated rs s)) +hydrateSeededThrough replayThrough options eventStream targetStream seedState seedRegisters seedVersion = do + replayed <- + Streamly.fold + (Fold.foldlM' replayPage (pure (Right initialReplay))) + recordedPages + pure (finishReplay replayed) + where + readPageSize = Prelude.max 1 (options ^. #pageSize) + groupSize = Prelude.fromIntegral readPageSize + recordedPages = + Streamly.foldMany + (Fold.take groupSize Fold.toList) + boundedRecorded + boundedRecorded = + case replayThrough of + Nothing -> readStreamForwardStream resolvedName seedVersion readPageSize + Just endVersion -> + Streamly.takeWhile + (\recorded -> recorded ^. #streamVersion <= endVersion) + (readStreamForwardStream resolvedName seedVersion readPageSize) + resolvedName = (eventStream ^. #resolveStreamName) targetStream + initialReplay = (Keiki.Settled seedState, seedRegisters, Nothing) + + replayPage :: + Either CommandError (Keiki.InFlight s co, RegFile rs, Maybe RecordedEvent) -> + [RecordedEvent] -> + Eff es (Either CommandError (Keiki.InFlight s co, RegFile rs, Maybe RecordedEvent)) + replayPage (Left err) _ = pure (Left err) + replayPage (Right (wrapper, registers, previousRecorded)) page = + pure $ case Keiki.replayEvents (eventStream ^. #transducer) (wrapper, registers) decodedEvents of + Left replayFailure -> + Left (hydrationReplayError previousRecorded decodedRecorded replayFailure) + Right (nextWrapper, nextRegisters) -> + case pendingInputFailure of + Just err -> Left err + Nothing -> + Right + ( nextWrapper, + nextRegisters, + latestRecorded decodedRecorded previousRecorded + ) + where + (decodedRecorded, decodedEvents, pendingInputFailure) = decodePrefix previousRecorded page + + decodePrefix :: Maybe RecordedEvent -> [RecordedEvent] -> ([RecordedEvent], [co], Maybe CommandError) + decodePrefix previousRecorded = go [] [] startingVersion + where + startingVersion = maybe seedVersion (^. #streamVersion) previousRecorded + + go recordedAcc eventAcc lastSeen = \case + [] -> (Prelude.reverse recordedAcc, Prelude.reverse eventAcc, Nothing) + recorded : rest -> + let observed = recorded ^. #streamVersion + expected = nextStreamVersion lastSeen + in if observed /= expected + then + ( Prelude.reverse recordedAcc, + Prelude.reverse eventAcc, + Just (HydrationGapDetected expected observed) + ) + else case decodeRecorded (eventStream ^. #eventCodec) recorded of + Left err -> + ( Prelude.reverse recordedAcc, + Prelude.reverse eventAcc, + Just (HydrationDecodeFailed err) + ) + Right event -> + go (recorded : recordedAcc) (event : eventAcc) observed rest + + nextStreamVersion (StreamVersion version) = StreamVersion (version Prelude.+ 1) + + hydrationReplayError :: + Maybe RecordedEvent -> + [RecordedEvent] -> + Keiki.ReplayFailure s co -> + CommandError + hydrationReplayError previousRecorded decodedRecorded replayFailure = + HydrationReplayFailed failureVersion (toHydrationReason (Keiki.replayFailureReason replayFailure)) + where + failureVersion = + maybe seedVersion (^. #streamVersion) failureRecorded + failureRecorded = + case Keiki.replayFailureReason replayFailure of + Keiki.ReplayLogTruncated {} -> latestRecorded decodedRecorded previousRecorded + Keiki.ReplayEventFailed {} -> + case recordedAt (Keiki.replayFailedIndex replayFailure) decodedRecorded of + Just recorded -> Just recorded + Nothing -> latestRecorded decodedRecorded previousRecorded + + finishReplay = \case + Left err -> Left err + Right (wrapper, finalRegisters, lastRecorded) -> + case wrapper of + Keiki.Settled finalState -> + Right + Hydrated + { state = finalState, + registers = finalRegisters, + streamVersion = maybe seedVersion (^. #streamVersion) lastRecorded + } + Keiki.InFlight {} -> + Left + ( HydrationReplayFailed + (maybe seedVersion (^. #streamVersion) lastRecorded) + HydrationTruncatedChain + ) + + toHydrationReason = \case + Keiki.ReplayEventFailed stepFailure -> case stepFailure of + Keiki.ReplayNoInvertingEdge {} -> HydrationNoInvertingEdge + Keiki.ReplayAmbiguousInversions {} -> HydrationAmbiguousInversion + Keiki.ReplayQueueMismatch {} -> HydrationQueueMismatch + Keiki.ReplayLogTruncated {} -> HydrationTruncatedChain + + latestRecorded recorded fallback = + case lastMaybe recorded of + Just latest -> Just latest + Nothing -> fallback + + lastMaybe = \case + [] -> Nothing + first : rest -> Just (Prelude.foldl (\_ current -> current) first rest) + + recordedAt eventIndex recorded = + case Prelude.drop eventIndex recorded of + found : _ -> Just found + [] -> Nothing + +scheduleSeedVerification :: + forall phi rs s ci co es. + (HasCallStack, IOE :> es, Store :> es, BoolAlg phi (RegFile rs, ci), Eq co) => + RunCommandOptions -> + EventStream phi rs s ci co -> + Stream (EventStream phi rs s ci co) -> + StateCodec (s, RegFile rs) -> + SnapshotSeed rs s -> + Eff es () +scheduleSeedVerification options eventStream targetStream codec seed = do + void $ trySync $ do + sampled <- + case options ^. #seedVerifySampleRate of + rate | rate <= 0 -> pure False + 1 -> pure True + rate -> liftIO ((== (1 :: Int)) <$> uniformRM (1, rate) globalStdGen) + when sampled + $ void + $ runConcurrent + $ Async.async + $ verifySnapshotSeed options eventStream targetStream codec seed + +verifySnapshotSeed :: + forall phi rs s ci co es. + (HasCallStack, IOE :> es, Store :> es, BoolAlg phi (RegFile rs, ci), Eq co) => + RunCommandOptions -> + EventStream phi rs s ci co -> + Stream (EventStream phi rs s ci co) -> + StateCodec (s, RegFile rs) -> + SnapshotSeed rs s -> + Eff es () +verifySnapshotSeed options eventStream targetStream codec seed = do + let seedVersion = seed ^. #streamVersion + streamName = (eventStream ^. #resolveStreamName) targetStream + full <- + hydrateSeededThrough + (Just seedVersion) + options + eventStream + targetStream + (eventStream ^. #initialState) + (eventStream ^. #initialRegisters) + (StreamVersion 0) + seededEncoded <- + liftIO + $ encodeSnapshotStrict + codec + (seed ^. #state, seed ^. #registers) + case (seededEncoded, full) of + (Left seedEncodeError, _) -> + reportSeedDivergence + options + streamName + seedVersion + ("encode-failed:" <> Text.pack (displayException seedEncodeError)) + (case full of Left replayError -> "replay-failed:" <> Text.pack (show replayError); Right _ -> "not-compared:seed-encode-failed") + (Right seededValue, Left replayError) -> + reportSeedDivergence + options + streamName + seedVersion + (replayDigest seededValue) + ("replay-failed:" <> Text.pack (show replayError)) + (Right seededValue, Right fullHydrated) + | fullHydrated ^. #streamVersion /= seedVersion -> + reportSeedDivergence + options + streamName + seedVersion + (replayDigest seededValue) + ("version-mismatch:" <> Text.pack (show (fullHydrated ^. #streamVersion))) + | otherwise -> do + fullEncoded <- + liftIO + $ encodeSnapshotStrict + codec + (fullHydrated ^. #state, fullHydrated ^. #registers) + case fullEncoded of + Left fullEncodeError -> + reportSeedDivergence + options + streamName + seedVersion + (replayDigest seededValue) + ("encode-failed:" <> Text.pack (displayException fullEncodeError)) + Right fullValue -> + unless + (canonicalJsonBytes seededValue == canonicalJsonBytes fullValue) + ( reportSeedDivergence + options + streamName + seedVersion + (replayDigest seededValue) + (replayDigest fullValue) + ) + +reportSeedDivergence :: + (IOE :> es) => + RunCommandOptions -> + StreamName -> + StreamVersion -> + Text -> + Text -> + Eff es () +reportSeedDivergence options (StreamName streamName) (StreamVersion seedVersion) seededDigest fullDigest = do + recordSnapshotSeedDivergence (options ^. #metrics) 1 + liftIO + $ LazyByteString.hPutStrLn stderr + $ Aeson.encode + $ Aeson.object + [ "event" Aeson..= ("keiro.snapshot.seed.divergence" :: Text), + "level" Aeson..= ("error" :: Text), + "stream" Aeson..= streamName, + "seedVersion" Aeson..= seedVersion, + "seededDigest" Aeson..= seededDigest, + "fullDigest" Aeson..= fullDigest + ] + +-- | Hydrate the target stream, transduce the command, and append any emitted +-- events. Retries optimistic-concurrency conflicts up to 'retryLimit'. This +-- is the plain runner with no in-transaction side effects. +runCommand :: + forall phi rs s ci co es. + (HasCallStack, IOE :> es, Store :> es, Error StoreError :> es, BoolAlg phi (RegFile rs, ci), Eq co) => + RunCommandOptions -> + ValidatedEventStream phi rs s ci co -> + Stream (EventStream phi rs s ci co) -> + ci -> + Eff es (Either CommandError (CommandResult (EventStream phi rs s ci co))) +runCommand options validatedEventStream targetStream command = + withCommandSpan (options ^. #tracer) (resolvedStreamName eventStream targetStream) Nothing $ \mSpan -> do + (result, attemptNo) <- attempt mSpan 1 Nothing + recordCommandOutcome mSpan (^. #eventsAppended) attemptNo result + pure result + where + eventStream = unvalidated validatedEventStream + + attempt mSpan attemptNo lastConflict = do + hydrated <- hydrate options eventStream targetStream + either (\err -> pure (Left err, attemptNo)) (runPlan mSpan attemptNo lastConflict) hydrated + + runPlan mSpan attemptNo lastConflict current = + case conflictFixpoint lastConflict (current ^. #streamVersion) of + Just err -> pure (Left err, attemptNo) + Nothing -> + case prepareCommandPlan options eventStream targetStream current command of + Left err -> pure (Left err, attemptNo) + Right (CommandNoOp result) -> pure (Right result, attemptNo) + Right (CommandAppend current' events encoded) -> + appendOnce mSpan attemptNo current' events encoded + + appendOnce mSpan attemptNo current events encoded = do + liftIO (options ^. #beforeAppend) + appended <- + tryError @StoreError + $ appendToStream + ((eventStream ^. #resolveStreamName) targetStream) + (expectedVersion (current ^. #streamVersion)) + encoded + case appended of + Right appendResult -> do + verifyAndSnapshot options mSpan eventStream current events appendResult + pure (Right (appendedResult targetStream appendResult (Prelude.length encoded)), attemptNo) + Left (_, storeError) -> + retryOrFail options (attempt mSpan) attemptNo (current ^. #streamVersion) storeError + +-- | Like 'runCommand', but run @afterAppend@ inside the /same/ transaction +-- as the append, so a read-model write commits atomically with the events. +-- The callback's result is returned as @Just@ on append (and 'Nothing' for a +-- no-op command that appended nothing). +-- +-- Requires 'KirokuStoreResource' so the transactional append applies the +-- configured @enrichEvent@ hook. See 'runCommandWithSqlEvents' for the callback's +-- locking and latency implications. +runCommandWithSql :: + forall phi rs s ci co a es. + (HasCallStack, IOE :> es, Store :> es, Error StoreError :> es, KirokuStoreResource :> es, BoolAlg phi (RegFile rs, ci), Eq co) => + RunCommandOptions -> + ValidatedEventStream phi rs s ci co -> + Stream (EventStream phi rs s ci co) -> + ci -> + (AppendResult -> Tx.Transaction a) -> + Eff es (Either CommandError (CommandResult (EventStream phi rs s ci co), Maybe a)) +runCommandWithSql options eventStream targetStream command afterAppend = + runCommandWithSqlEvents options eventStream targetStream command (\_ appendResult -> afterAppend appendResult) + +-- | The most general runner: like 'runCommandWithSql', but the +-- in-transaction callback also receives every emitted event paired with the +-- 'RecordedEvent' the store persisted for it, in append order. Inline +-- projections, process managers, and routers are all built on this. +-- +-- The runner requires 'KirokuStoreResource' and applies the configured +-- @enrichEvent@ hook before preparing the append. The callback therefore sees +-- the enriched metadata that was persisted. +-- +-- The append updates Kiroku's global @$all@ stream and holds its PostgreSQL row +-- lock until this transaction commits. Every SQL operation in the callback +-- therefore extends the store-wide append serialization window. Keep the +-- callback small: precompute outside the transaction where possible, batch +-- writes, and minimize database round trips. +runCommandWithSqlEvents :: + forall phi rs s ci co a es. + (HasCallStack, IOE :> es, Store :> es, Error StoreError :> es, KirokuStoreResource :> es, BoolAlg phi (RegFile rs, ci), Eq co) => + RunCommandOptions -> + ValidatedEventStream phi rs s ci co -> + Stream (EventStream phi rs s ci co) -> + ci -> + ([(co, RecordedEvent)] -> AppendResult -> Tx.Transaction a) -> + Eff es (Either CommandError (CommandResult (EventStream phi rs s ci co), Maybe a)) +runCommandWithSqlEvents options validatedEventStream targetStream command afterAppend = + withCommandSpan (options ^. #tracer) (resolvedStreamName eventStream targetStream) Nothing $ \mSpan -> do + (result, attemptNo) <- attempt mSpan 1 Nothing + recordCommandOutcome mSpan (\(r, _) -> r ^. #eventsAppended) attemptNo result + pure result + where + eventStream = unvalidated validatedEventStream + + attempt mSpan attemptNo lastConflict = do + hydrated <- hydrate options eventStream targetStream + either (\err -> pure (Left err, attemptNo)) (runPlan mSpan attemptNo lastConflict) hydrated + + runPlan mSpan attemptNo lastConflict current = + case conflictFixpoint lastConflict (current ^. #streamVersion) of + Just err -> pure (Left err, attemptNo) + Nothing -> + case prepareCommandPlan options eventStream targetStream current command of + Left err -> pure (Left err, attemptNo) + Right (CommandNoOp result) -> pure (Right (result, Nothing), attemptNo) + Right (CommandAppend current' events encoded) -> + appendWithSqlOnce mSpan attemptNo current' events encoded + + appendWithSqlOnce mSpan attemptNo current events encoded = do + liftIO (options ^. #beforeAppend) + store <- getKirokuStore + enriched <- liftIO (enrichEventsIO store encoded) + prepared <- prepareEventsIO enriched + now <- liftIO getCurrentTime + let streamName = (eventStream ^. #resolveStreamName) targetStream + expected = expectedVersion (current ^. #streamVersion) + body = do + appended <- appendToStreamTx streamName expected prepared now + case appended of + Left conflict -> + Tx.condemn $> Left (appendConflictToStoreError conflict) + Right appendResult -> do + let recordeds = reconstructRecorded appendResult now prepared + userValue <- afterAppend (Prelude.zip events recordeds) appendResult + pure (Right (appendResult, userValue)) + outcome <- tryError @StoreError (runTransaction body) + case outcome of + Right (Right (appendResult, userValue)) -> do + verifyAndSnapshot options mSpan eventStream current events appendResult + pure (Right (appendedResult targetStream appendResult (Prelude.length encoded), Just userValue), attemptNo) + Right (Left storeError) -> + retryOrFail options (attempt mSpan) attemptNo (current ^. #streamVersion) storeError + Left (_, storeError) -> + retryOrFail options (attempt mSpan) attemptNo (current ^. #streamVersion) storeError + +prepareCommandPlan :: + (BoolAlg phi (RegFile rs, ci)) => + RunCommandOptions -> + EventStream phi rs s ci co -> + Stream (EventStream phi rs s ci co) -> + Hydrated rs s -> + ci -> + Either CommandError (CommandPlan (EventStream phi rs s ci co) rs s co) +prepareCommandPlan options eventStream targetStream current command = + case evaluateCommand eventStream current command of + Left err -> Left err + Right events -> toPlan events + where + toPlan [] = + Right (CommandNoOp (noOpResult targetStream current)) + toPlan events = + CommandAppend current events + . assignEventIds (options ^. #eventIds) + <$> encodeEvents (eventStream ^. #eventCodec) (options ^. #metadata) events + +-- | Render the stream that the command targets as plain 'Text', for use +-- as a span name. +resolvedStreamName :: + EventStream phi rs s ci co -> + Stream (EventStream phi rs s ci co) -> + Text +resolvedStreamName eventStream targetStream = + case (eventStream ^. #resolveStreamName) targetStream of + StreamName n -> n + +-- | Attach the command-span outcome attributes after the runner returns. +-- +-- On success: 'db.system.name' and 'keiro.events.appended'. +-- On failure: 'error.type' (low-cardinality classifier) and span status +-- 'Error' (carrying the rendered 'CommandError' as the description). +-- +-- Pure no-op when no span is active ('Nothing' tracer, etc). +recordCommandOutcome :: + (IOE :> es) => + Maybe Span -> + (a -> Int) -> + Int -> + Either CommandError a -> + Eff es () +recordCommandOutcome Nothing _ _ _ = pure () +recordCommandOutcome (Just sp) eventsOf attemptNo result = do + addAttribute sp (unkey db_system_name) ("postgresql" :: Text) + addAttribute sp (unkey keiro_retry_attempt) (Prelude.fromIntegral attemptNo :: Int64) + case result of + Right v -> + addAttribute sp (unkey keiro_events_appended) (Prelude.fromIntegral (eventsOf v) :: Int64) + Left err -> do + addAttribute sp (unkey error_type) (commandErrorClass err) + setStatus sp (Error (Text.take 256 (Text.pack (show err)))) + +-- | Low-cardinality classifier for a 'CommandError'. Used as the +-- @error.type@ attribute value on the command span. +commandErrorClass :: CommandError -> Text +commandErrorClass = \case + HydrationDecodeFailed {} -> "hydration_decode_failed" + HydrationReplayFailed _ HydrationNoInvertingEdge -> "hydration_replay_no_inverting_edge" + HydrationReplayFailed _ HydrationAmbiguousInversion -> "hydration_replay_ambiguous_inversion" + HydrationReplayFailed _ HydrationQueueMismatch -> "hydration_replay_queue_mismatch" + HydrationReplayFailed _ HydrationTruncatedChain -> "hydration_replay_truncated_chain" + HydrationGapDetected {} -> "hydration_gap_detected" + CommandRejected -> "command_rejected" + CommandAmbiguous {} -> "command_ambiguous" + EncodeFailed {} -> "encode_failed" + StoreFailed {} -> "store_failed" + RetryExhausted {} -> "retry_exhausted" + ConflictFixpoint {} -> "conflict_fixpoint" + +verifyAndSnapshot :: + forall phi rs s ci co es. + (BoolAlg phi (RegFile rs, ci), IOE :> es, Store :> es, Error StoreError :> es, Eq co) => + RunCommandOptions -> + Maybe Span -> + EventStream phi rs s ci co -> + Hydrated rs s -> + [co] -> + AppendResult -> + Eff es () +verifyAndSnapshot options mSpan eventStream current events appendResult + | Prelude.not (options ^. #verifyReplayOnAppend), + Nothing <- eventStream ^. #stateCodec = + pure () + | otherwise = + case Keiki.applyEventsEither (eventStream ^. #transducer) (state current, registers current) events of + Left failure -> do + recordSnapshotApplyDivergence (options ^. #metrics) 1 + for_ mSpan $ \sp -> + addAttribute + sp + (unkey keiro_replay_divergence) + (Text.take 256 (renderReplayFailure failure)) + Right finalState -> + case eventStream ^. #stateCodec of + Nothing -> pure () + Just codec -> do + let finalVersion = appendResult ^. #streamVersion + terminality = + if Keiki.isFinal (eventStream ^. #transducer) (Prelude.fst finalState) + then Terminal + else NotTerminal + when (shouldSnapshotSpan (eventStream ^. #snapshotPolicy) terminality finalState (current ^. #streamVersion) finalVersion) + $ do + encoded <- liftIO (encodeSnapshotStrict codec finalState) + case encoded of + Left _ -> recordSnapshotEncodeFailures (options ^. #metrics) 1 + Right value -> do + outcome <- tryError @StoreError (writeSnapshotEncoded (appendResult ^. #streamId) finalVersion codec value) + case outcome of + Right () -> pure () + Left _ -> recordSnapshotWriteFailures (options ^. #metrics) 1 + +renderReplayFailure :: Keiki.ReplayFailure s co -> Text +renderReplayFailure failure = + "event_index=" + <> Text.pack (show (Keiki.replayFailedIndex failure)) + <> ";reason=" + <> case Keiki.replayFailureReason failure of + Keiki.ReplayEventFailed stepFailure -> case stepFailure of + Keiki.ReplayNoInvertingEdge {} -> "no_inverting_edge" + Keiki.ReplayAmbiguousInversions {} -> "ambiguous_inversions" + Keiki.ReplayQueueMismatch {} -> "queue_mismatch" + Keiki.ReplayLogTruncated {} -> "log_truncated" + +retryOrFail :: + (IOE :> es) => + RunCommandOptions -> + (Int -> Maybe (StoreError, StreamVersion) -> Eff es (Either CommandError a, Int)) -> + Int -> + StreamVersion -> + StoreError -> + Eff es (Either CommandError a, Int) +retryOrFail options retry attemptNo observedVersion storeError + | isRetryableConflict storeError, + attemptNo <= options ^. #retryLimit = do + recordCommandConflicts (options ^. #metrics) 1 + backoffDelay options attemptNo + recordCommandRetries (options ^. #metrics) 1 + retry (attemptNo Prelude.+ 1) (Just (storeError, observedVersion)) + | isRetryableConflict storeError = do + recordCommandConflicts (options ^. #metrics) 1 + pure (Left (RetryExhausted attemptNo storeError), attemptNo) + | otherwise = do + case storeError of + DuplicateEvent {} -> recordCommandDuplicates (options ^. #metrics) 1 + _ -> pure () + pure (Left (StoreFailed storeError), attemptNo) + +backoffDelay :: (IOE :> es) => RunCommandOptions -> Int -> Eff es () +backoffDelay options attemptNo + | base <= 0 = pure () + | otherwise = do + nanos <- liftIO getMonotonicTimeNSec + let exponential = min 100000 (base Prelude.* (2 Prelude.^ (attemptNo Prelude.- 1 :: Int))) + jitter = + Prelude.fromIntegral (nanos `Prelude.mod` Prelude.fromIntegral exponential) + Prelude.- (exponential `Prelude.div` 2) + liftIO (threadDelay (max 0 (exponential Prelude.+ jitter))) + where + base = options ^. #retryBackoffMicros + +conflictFixpoint :: Maybe (StoreError, StreamVersion) -> StreamVersion -> Maybe CommandError +conflictFixpoint (Just (previousError@StreamAlreadyExists {}, previousVersion)) currentVersion + | currentVersion == previousVersion = Just (ConflictFixpoint currentVersion previousError) +conflictFixpoint _ _ = Nothing + +evaluateCommand :: + (BoolAlg phi (RegFile rs, ci)) => + EventStream phi rs s ci co -> + Hydrated rs s -> + ci -> + Either CommandError [co] +evaluateCommand eventStream current command = + case Keiki.stepEither (eventStream ^. #transducer) (state current, registers current) command of + Left Keiki.NoOutgoingEdges {} -> Left CommandRejected + Left Keiki.NoMatchingEdge {} -> Left CommandRejected + Left (Keiki.AmbiguousEdges _ matches) -> + Left + ( CommandAmbiguous + [ Keiki.edgeIndex (Keiki.matchedEdge matched) + | matched <- matches + ] + ) + Right (_, _, events) -> Right events + +encodeEvents :: Codec co -> Maybe Value -> [co] -> Either CommandError [EventData] +encodeEvents codec md = + Prelude.mapM (mapLeft EncodeFailed . encodeForAppendWithMetadata codec md) + +assignEventIds :: [EventId] -> [EventData] -> [EventData] +assignEventIds [] events = events +assignEventIds _ [] = [] +assignEventIds (supplied : suppliedRest) (event : eventRest) = + (event & #eventId .~ Just supplied) : assignEventIds suppliedRest eventRest + +expectedVersion :: StreamVersion -> ExpectedVersion +expectedVersion (StreamVersion 0) = NoStream +expectedVersion version = ExactVersion version + +noOpResult :: + Stream target -> + Hydrated rs s -> + CommandResult target +noOpResult targetStream current = + CommandResult + { target = targetStream, + streamVersion = current ^. #streamVersion, + globalPosition = Nothing, + eventsAppended = 0 + } + +appendedResult :: + Stream target -> + AppendResult -> + Int -> + CommandResult target +appendedResult targetStream appendResult count = + CommandResult + { target = targetStream, + streamVersion = appendResult ^. #streamVersion, + globalPosition = Just (appendResult ^. #globalPosition), + eventsAppended = count + } + +-- | Rebuild the per-event 'RecordedEvent' values for a just-appended batch. +-- +-- The store assigns each event in a batch a contiguous stream version and +-- global position: event @i@ (1-based) gets @last - count + i@ for both +-- counters, where @last@ is the position the 'AppendResult' reports for the +-- final event and @count@ is the batch size. (The kiroku append SQL numbers +-- events with @WITH ORDINALITY@ and inserts @initial + idx@; see EP-27's +-- Surprises & Discoveries.) We therefore reconstruct each 'RecordedEvent' +-- exactly, rather than reading the batch back. The @createdAt@ is the same +-- timestamp 'prepareEventsIO'/'appendToStreamTx' used for the insert. +-- +-- This is a source append (events are written to their own stream), so +-- @streamVersion == originalVersion@ and @originalStreamId@ is the appended +-- stream's id, per the 'RecordedEvent' contract. +reconstructRecorded :: AppendResult -> UTCTime -> [PreparedEvent] -> [RecordedEvent] +reconstructRecorded appendResult now prepared = + Prelude.zipWith mk [0 ..] prepared + where + count = Prelude.length prepared + StreamVersion lastSv = appendResult ^. #streamVersion + GlobalPosition lastGp = appendResult ^. #globalPosition + firstSv = lastSv Prelude.- Prelude.fromIntegral count Prelude.+ 1 + firstGp = lastGp Prelude.- Prelude.fromIntegral count Prelude.+ 1 + mk :: Int64 -> PreparedEvent -> RecordedEvent + mk i prepared' = + RecordedEvent + { eventId = EventId (prepared' ^. #peEventId), + eventType = prepared' ^. #peEventType, + streamVersion = StreamVersion (firstSv Prelude.+ i), + globalPosition = GlobalPosition (firstGp Prelude.+ i), + originalStreamId = appendResult ^. #streamId, + originalVersion = StreamVersion (firstSv Prelude.+ i), + payload = prepared' ^. #pePayload, + metadata = prepared' ^. #peMetadata, + causationId = prepared' ^. #peCausationId, + correlationId = prepared' ^. #peCorrelationId, + createdAt = now + } + +isRetryableConflict :: StoreError -> Bool +isRetryableConflict = \case + WrongExpectedVersion {} -> True + StreamAlreadyExists {} -> True + _ -> False + +mapLeft :: (e -> e') -> Either e a -> Either e' a +mapLeft f = \case + Left err -> Left (f err) + Right value -> Right value diff --git a/src/Keiro/Connection.hs b/src/Keiro/Connection.hs --- a/src/Keiro/Connection.hs +++ b/src/Keiro/Connection.hs @@ -1,41 +1,40 @@ -{- | Schema-resolution helpers for application read-model and projection tables. - -Keiro's own framework tables live in the dedicated @keiro@ schema and its -runtime queries are fully qualified there. This module is about the /third/ -layer: where an application's read-model /data/ tables live, and how the -application declares and reaches that location. - -A PostgreSQL /schema/ is a namespace of tables inside one database. Because -Keiro opens its database pool through kiroku's connection settings — whose -@search_path@ starts with the event store's private @kiroku@ schema — an -unqualified @CREATE TABLE my_read_model (...)@ would land the table inside the -@kiroku@ event-store schema. To place it elsewhere, the application must -qualify at least its @CREATE TABLE@ as @schema.table@ (an unqualified create -always lands in the first @search_path@ entry). Qualifying the read/write SQL -too makes everything correct regardless of @search_path@ — the robust default. - -This module gives applications exactly one convention: - -* 'qualifyTable' builds a double-quoted, schema-qualified table reference to - interpolate into projection SQL. -* 'withProjectionSchema' / 'keiroConnectionSettings' wire the store connection - so a chosen projection schema also /resolves/ on the pool (via kiroku's - @extraSearchPath@), for applications that also want unqualified SQL to work. -* 'ensureProjectionSchema' is an opt-in @CREATE SCHEMA IF NOT EXISTS@ helper for - development, tests, and worked examples; Keiro never calls it automatically. - -The kiroku store connection's @schema@ field stays @kiroku@ and is never -repointed: it also drives the @.events@ @LISTEN@/@NOTIFY@ channel, so -changing it would break subscription wake-ups. The projection schema is reached -only by qualification and\/or @extraSearchPath@. --} -module Keiro.Connection ( - qualifyTable, +-- | Schema-resolution helpers for application read-model and projection tables. +-- +-- Keiro's own framework tables live in the dedicated @keiro@ schema and its +-- runtime queries are fully qualified there. This module is about the /third/ +-- layer: where an application's read-model /data/ tables live, and how the +-- application declares and reaches that location. +-- +-- A PostgreSQL /schema/ is a namespace of tables inside one database. Because +-- Keiro opens its database pool through kiroku's connection settings — whose +-- @search_path@ starts with the event store's private @kiroku@ schema — an +-- unqualified @CREATE TABLE my_read_model (...)@ would land the table inside the +-- @kiroku@ event-store schema. To place it elsewhere, the application must +-- qualify at least its @CREATE TABLE@ as @schema.table@ (an unqualified create +-- always lands in the first @search_path@ entry). Qualifying the read/write SQL +-- too makes everything correct regardless of @search_path@ — the robust default. +-- +-- This module gives applications exactly one convention: +-- +-- * 'qualifyTable' builds a double-quoted, schema-qualified table reference to +-- interpolate into projection SQL. +-- * 'withProjectionSchema' / 'keiroConnectionSettings' wire the store connection +-- so a chosen projection schema also /resolves/ on the pool (via kiroku's +-- @extraSearchPath@), for applications that also want unqualified SQL to work. +-- * 'ensureProjectionSchema' is an opt-in @CREATE SCHEMA IF NOT EXISTS@ helper for +-- development, tests, and worked examples; Keiro never calls it automatically. +-- +-- The kiroku store connection's @schema@ field stays @kiroku@ and is never +-- repointed: it also drives the @.events@ @LISTEN@/@NOTIFY@ channel, so +-- changing it would break subscription wake-ups. The projection schema is reached +-- only by qualification and\/or @extraSearchPath@. +module Keiro.Connection + ( qualifyTable, quoteIdentifier, withProjectionSchema, keiroConnectionSettings, ensureProjectionSchema, -) + ) where import Data.Text qualified as T @@ -47,54 +46,49 @@ import Kiroku.Store.Transaction (runTransaction) import "hasql-transaction" Hasql.Transaction qualified as Tx -{- | Build a double-quoted, schema-qualified table reference @"schema"."table"@, -doubling any embedded double quotes (the same identifier quoting kiroku uses). -Interpolate the result directly into projection SQL, e.g. - -@ -"SELECT ... FROM " <> qualifyTable "app" "orders" <> " WHERE ..." -@ --} +-- | Build a double-quoted, schema-qualified table reference @"schema"."table"@, +-- doubling any embedded double quotes (the same identifier quoting kiroku uses). +-- Interpolate the result directly into projection SQL, e.g. +-- +-- @ +-- "SELECT ... FROM " <> qualifyTable "app" "orders" <> " WHERE ..." +-- @ qualifyTable :: Text -> Text -> Text qualifyTable schema table = quoteIdentifier schema <> "." <> quoteIdentifier table -{- | Double-quote a single SQL identifier, doubling any embedded double quotes -(the same identifier quoting kiroku uses). Useful for building qualified names -or a @CREATE SCHEMA ""@ statement. --} +-- | Double-quote a single SQL identifier, doubling any embedded double quotes +-- (the same identifier quoting kiroku uses). Useful for building qualified names +-- or a @CREATE SCHEMA ""@ statement. quoteIdentifier :: Text -> Text quoteIdentifier ident = "\"" <> T.replace "\"" "\"\"" ident <> "\"" -{- | Append @projectionSchema@ to a settings value's @extraSearchPath@ so a -pooled connection can /resolve/ (read\/write) application tables in that schema. -Idempotent: the schema is appended only if not already present. The store's -@schema@ field is left untouched (stays @kiroku@). --} +-- | Append @projectionSchema@ to a settings value's @extraSearchPath@ so a +-- pooled connection can /resolve/ (read\/write) application tables in that schema. +-- Idempotent: the schema is appended only if not already present. The store's +-- @schema@ field is left untouched (stays @kiroku@). withProjectionSchema :: Text -> ConnectionSettings -> ConnectionSettings withProjectionSchema projectionSchema settings = - settings & #extraSearchPath %~ appendUnique projectionSchema + settings & #extraSearchPath %~ appendUnique projectionSchema where appendUnique s xs - | s `elem` xs = xs - | otherwise = xs <> [s] + | s `elem` xs = xs + | otherwise = xs <> [s] -{- | kiroku's default connection settings (@schema = "kiroku"@) with -@projectionSchema@ added to @extraSearchPath@, so unqualified application -data-manipulation SQL resolves on the store pool while the store @schema@ stays -@kiroku@ (honoring the NOTIFY-channel constraint). This does /not/ bake Keiro's -own @keiro@ schema into @extraSearchPath@: Keiro's runtime queries are already -fully qualified and must not depend on @search_path@. --} +-- | kiroku's default connection settings (@schema = "kiroku"@) with +-- @projectionSchema@ added to @extraSearchPath@, so unqualified application +-- data-manipulation SQL resolves on the store pool while the store @schema@ stays +-- @kiroku@ (honoring the NOTIFY-channel constraint). This does /not/ bake Keiro's +-- own @keiro@ schema into @extraSearchPath@: Keiro's runtime queries are already +-- fully qualified and must not depend on @search_path@. keiroConnectionSettings :: Text -> Text -> ConnectionSettings keiroConnectionSettings connString projectionSchema = - withProjectionSchema projectionSchema (defaultConnectionSettings connString) + withProjectionSchema projectionSchema (defaultConnectionSettings connString) -{- | Run @CREATE SCHEMA IF NOT EXISTS ""@ in a transaction. This is -opt-in: Keiro never calls it automatically. Use it in development, tests, and -worked examples where the application (not a production migration tool) owns -schema creation. --} +-- | Run @CREATE SCHEMA IF NOT EXISTS ""@ in a transaction. This is +-- opt-in: Keiro never calls it automatically. Use it in development, tests, and +-- worked examples where the application (not a production migration tool) owns +-- schema creation. ensureProjectionSchema :: (Store :> es) => Text -> Eff es () ensureProjectionSchema projectionSchema = - runTransaction $ - Tx.sql (TE.encodeUtf8 ("CREATE SCHEMA IF NOT EXISTS " <> quoteIdentifier projectionSchema)) + runTransaction $ + Tx.sql (TE.encodeUtf8 ("CREATE SCHEMA IF NOT EXISTS " <> quoteIdentifier projectionSchema)) diff --git a/src/Keiro/DeadLetter.hs b/src/Keiro/DeadLetter.hs --- a/src/Keiro/DeadLetter.hs +++ b/src/Keiro/DeadLetter.hs @@ -1,27 +1,26 @@ -{- | Durable records for process-manager and router dispatches rejected by a -target state machine. - -Use 'recordDispatchDeadLetter' from a worker before acknowledging its source -event, and 'listDispatchDeadLetters' to inspect the durable witnesses for one -dispatcher. Inserts are idempotent under source-event redelivery. --} -module Keiro.DeadLetter ( - DispatcherKind (..), +-- | Durable records for process-manager and router dispatches rejected by a +-- target state machine. +-- +-- Use 'recordDispatchDeadLetter' from a worker before acknowledging its source +-- event, and 'listDispatchDeadLetters' to inspect the durable witnesses for one +-- dispatcher. Inserts are idempotent under source-event redelivery. +module Keiro.DeadLetter + ( DispatcherKind (..), DispatchDeadLetter (..), DispatchDeadLetterRecord (..), recordDispatchDeadLetter, listDispatchDeadLetters, -) + ) where import Effectful (Eff, (:>)) -import Keiro.DeadLetter.Schema ( - DispatchDeadLetter (..), +import Keiro.DeadLetter.Schema + ( DispatchDeadLetter (..), DispatchDeadLetterRecord (..), DispatcherKind (..), listDispatchDeadLettersTx, recordDispatchDeadLetterTx, - ) + ) import Keiro.Prelude import Kiroku.Store.Effect (Store) import Kiroku.Store.Transaction (runTransaction) diff --git a/src/Keiro/DeadLetter/Replay.hs b/src/Keiro/DeadLetter/Replay.hs --- a/src/Keiro/DeadLetter/Replay.hs +++ b/src/Keiro/DeadLetter/Replay.hs @@ -1,42 +1,41 @@ -{- | Operator replay for source events parked in Kiroku's -@kiroku.dead_letters@ table. - -The rows remain Kiroku-owned: replay neither deletes nor marks them. Instead it -re-runs a caller-supplied handler and relies on that handler's idempotency. This -is safe for "Keiro.ProcessManager" and "Keiro.Router" handlers because their -writes use deterministic event identifiers derived from the source event; -already-applied writes collapse to duplicate outcomes on every later replay. - -Kiroku exposes dead-letter rows by event id and global position, but does not -currently expose an exact point-read by either value. Global positions are -opaque cursors and must never be decremented. 'replaySubscriptionDeadLetters' -therefore scans the global stream backward using only @0@ and cursors returned -by Kiroku, matches both event id and position, and scans once for the whole -batch. A source event removed by hard deletion is reported as -'ReplaySourceMissing' and is not handed to the caller. - -A process-manager handler normally decodes the recorded event, calls -@runProcessManagerOnce@, and classifies a result whose manager state and every -target command are duplicates as 'ReplayedDuplicate'; any append makes it -'ReplayedFresh'. Return @Left detail@ for a decode or command failure. For -example, the classification has this shape: - -> case result of -> Left err -> Left (showText err) -> Right pmResult -> | managerAndEveryCommandAreDuplicates pmResult -> Right ReplayedDuplicate -> | otherwise -> Right ReplayedFresh - -Because rows are retained, an operator may safely run the same replay command -again after a partial failure or uncertain client disconnect. --} -module Keiro.DeadLetter.Replay ( - ReplayOutcome (..), +-- | Operator replay for source events parked in Kiroku's +-- @kiroku.dead_letters@ table. +-- +-- The rows remain Kiroku-owned: replay neither deletes nor marks them. Instead it +-- re-runs a caller-supplied handler and relies on that handler's idempotency. This +-- is safe for "Keiro.ProcessManager" and "Keiro.Router" handlers because their +-- writes use deterministic event identifiers derived from the source event; +-- already-applied writes collapse to duplicate outcomes on every later replay. +-- +-- Kiroku exposes dead-letter rows by event id and global position, but does not +-- currently expose an exact point-read by either value. Global positions are +-- opaque cursors and must never be decremented. 'replaySubscriptionDeadLetters' +-- therefore scans the global stream backward using only @0@ and cursors returned +-- by Kiroku, matches both event id and position, and scans once for the whole +-- batch. A source event removed by hard deletion is reported as +-- 'ReplaySourceMissing' and is not handed to the caller. +-- +-- A process-manager handler normally decodes the recorded event, calls +-- @runProcessManagerOnce@, and classifies a result whose manager state and every +-- target command are duplicates as 'ReplayedDuplicate'; any append makes it +-- 'ReplayedFresh'. Return @Left detail@ for a decode or command failure. For +-- example, the classification has this shape: +-- +-- > case result of +-- > Left err -> Left (showText err) +-- > Right pmResult +-- > | managerAndEveryCommandAreDuplicates pmResult -> Right ReplayedDuplicate +-- > | otherwise -> Right ReplayedFresh +-- +-- Because rows are retained, an operator may safely run the same replay command +-- again after a partial failure or uncertain client disconnect. +module Keiro.DeadLetter.Replay + ( ReplayOutcome (..), ReplayResult (..), DeadLetterRecord (..), listSubscriptionDeadLetters, replaySubscriptionDeadLetters, -) + ) where import Data.Int (Int32) @@ -55,88 +54,87 @@ import "hasql-transaction" Hasql.Transaction qualified as Tx data ReplayOutcome = ReplayOutcome - { replayGlobalPosition :: !GlobalPosition - , replayEventId :: !EventId - , replayResult :: !ReplayResult - } - deriving stock (Generic, Eq, Show) + { replayGlobalPosition :: !GlobalPosition, + replayEventId :: !EventId, + replayResult :: !ReplayResult + } + deriving stock (Generic, Eq, Show) data ReplayResult - = ReplayedFresh - | ReplayedDuplicate - | ReplayFailed !Text - | ReplaySourceMissing - deriving stock (Generic, Eq, Show) + = ReplayedFresh + | ReplayedDuplicate + | ReplayFailed !Text + | ReplaySourceMissing + deriving stock (Generic, Eq, Show) -- | List one Kiroku subscription member's dead letters, newest first. listSubscriptionDeadLetters :: - (Store :> es) => SubscriptionName -> Int32 -> Eff es (Vector DeadLetterRecord) + (Store :> es) => SubscriptionName -> Int32 -> Eff es (Vector DeadLetterRecord) listSubscriptionDeadLetters (SubscriptionName name) member = - runTransaction (Tx.statement (name, member) readDeadLettersStmt) - -{- | Replay every dead letter currently listed for one subscription member. + runTransaction (Tx.statement (name, member) readDeadLettersStmt) -The handler controls domain-specific decoding and decides whether its writes -were fresh or duplicates. A @Left detail@ is recorded in the corresponding -'ReplayOutcome' as 'ReplayFailed'; replay continues with later rows. Store -errors still surface through the surrounding Kiroku 'Store' interpreter. --} +-- | Replay every dead letter currently listed for one subscription member. +-- +-- The handler controls domain-specific decoding and decides whether its writes +-- were fresh or duplicates. A @Left detail@ is recorded in the corresponding +-- 'ReplayOutcome' as 'ReplayFailed'; replay continues with later rows. Store +-- errors still surface through the surrounding Kiroku 'Store' interpreter. replaySubscriptionDeadLetters :: - (Store :> es) => - SubscriptionName -> - Int32 -> - (RecordedEvent -> Eff es (Either Text ReplayResult)) -> - Eff es [ReplayOutcome] + (Store :> es) => + SubscriptionName -> + Int32 -> + (RecordedEvent -> Eff es (Either Text ReplayResult)) -> + Eff es [ReplayOutcome] replaySubscriptionDeadLetters subscriptionName member handler = do - rows <- listSubscriptionDeadLetters subscriptionName member - sources <- findSources rows - traverse (replayOne sources) (Vector.toList rows) + rows <- listSubscriptionDeadLetters subscriptionName member + sources <- findSources rows + traverse (replayOne sources) (Vector.toList rows) where replayOne sources row = do - let position = deadLetterPosition row - eventId = deadLetterEventIdValue row - result <- case Map.lookup eventId sources of - Just event - | event ^. #globalPosition == position -> do - handled <- handler event - pure (either ReplayFailed id handled) - _ -> pure ReplaySourceMissing - pure - ReplayOutcome - { replayGlobalPosition = position - , replayEventId = eventId - , replayResult = result - } + let position = deadLetterPosition row + eventId = deadLetterEventIdValue row + result <- case Map.lookup eventId sources of + Just event + | event ^. #globalPosition == position -> do + handled <- handler event + pure (either ReplayFailed id handled) + _ -> pure ReplaySourceMissing + pure + ReplayOutcome + { replayGlobalPosition = position, + replayEventId = eventId, + replayResult = result + } -- Scan once for the complete replay batch. Pages are descending, and the next -- cursor is always a position Kiroku returned; no global-position arithmetic. findSources :: - (Store :> es) => Vector DeadLetterRecord -> Eff es (Map EventId RecordedEvent) + (Store :> es) => Vector DeadLetterRecord -> Eff es (Map EventId RecordedEvent) findSources rows = go (GlobalPosition 0) Map.empty where wanted = - Map.fromList - [ (deadLetterEventIdValue row, deadLetterPosition row) - | row <- Vector.toList rows - ] + Map.fromList + [ (deadLetterEventIdValue row, deadLetterPosition row) + | row <- Vector.toList rows + ] go cursor found - | Map.size found == Map.size wanted = pure found - | otherwise = do - page <- readAllBackward cursor replayReadPageSize - if Vector.null page - then pure found - else do - let found' = Vector.foldl' remember found page - nextCursor = Vector.last page ^. #globalPosition - go nextCursor found' + | Map.size found == Map.size wanted = pure found + | otherwise = do + page <- readAllBackward cursor replayReadPageSize + if Vector.null page + then pure found + else do + let found' = Vector.foldl' remember found page + nextCursor = Vector.last page ^. #globalPosition + go nextCursor found' remember found event = - case Map.lookup (event ^. #eventId) wanted of - Just expectedPosition - | event ^. #globalPosition == expectedPosition -> - Map.insert (event ^. #eventId) event found - _ -> found + case Map.lookup (event ^. #eventId) wanted of + Just expectedPosition + | event ^. #globalPosition == expectedPosition -> + Map.insert (event ^. #eventId) event found + _ -> found replayReadPageSize :: Int32 replayReadPageSize = 256 diff --git a/src/Keiro/DeadLetter/Schema.hs b/src/Keiro/DeadLetter/Schema.hs --- a/src/Keiro/DeadLetter/Schema.hs +++ b/src/Keiro/DeadLetter/Schema.hs @@ -1,18 +1,17 @@ -{- | SQL storage for rejected process-manager and router dispatches. - -The @keiro.keiro_dead_letters@ table records a dispatched command that a -target state machine rejected. It is deliberately separate from Kiroku's -subscription dead-letter table: a row here describes one failed dispatch, -while the source subscription event is considered handled and may advance its -checkpoint. --} -module Keiro.DeadLetter.Schema ( - DispatcherKind (..), +-- | SQL storage for rejected process-manager and router dispatches. +-- +-- The @keiro.keiro_dead_letters@ table records a dispatched command that a +-- target state machine rejected. It is deliberately separate from Kiroku's +-- subscription dead-letter table: a row here describes one failed dispatch, +-- while the source subscription event is considered handled and may advance its +-- checkpoint. +module Keiro.DeadLetter.Schema + ( DispatcherKind (..), DispatchDeadLetter (..), DispatchDeadLetterRecord (..), recordDispatchDeadLetterTx, listDispatchDeadLettersTx, -) + ) where import Contravariant.Extras (contrazip10) @@ -29,137 +28,136 @@ -- | Which coordination primitive attempted the rejected dispatch. data DispatcherKind - = DispatcherProcessManager - | DispatcherRouter - deriving stock (Generic, Eq, Ord, Show) + = DispatcherProcessManager + | DispatcherRouter + deriving stock (Generic, Eq, Ord, Show) -- | Fields persisted for one rejected dispatch. data DispatchDeadLetter = DispatchDeadLetter - { dispatcherKind :: !DispatcherKind - , dispatcherName :: !Text - , correlationId :: !Text - , sourceEventId :: !EventId - , sourceGlobalPosition :: !GlobalPosition - , emitIndex :: !Int - , targetStreamName :: !StreamName - , errorClass :: !Text - , errorDetail :: !Text - , attemptCount :: !Int - } - deriving stock (Generic, Eq, Show) + { dispatcherKind :: !DispatcherKind, + dispatcherName :: !Text, + correlationId :: !Text, + sourceEventId :: !EventId, + sourceGlobalPosition :: !GlobalPosition, + emitIndex :: !Int, + targetStreamName :: !StreamName, + errorClass :: !Text, + errorDetail :: !Text, + attemptCount :: !Int + } + deriving stock (Generic, Eq, Show) -- | A persisted rejected dispatch, including database-managed identity and time. data DispatchDeadLetterRecord = DispatchDeadLetterRecord - { deadLetterId :: !Int64 - , dispatcherKind :: !DispatcherKind - , dispatcherName :: !Text - , correlationId :: !Text - , sourceEventId :: !EventId - , sourceGlobalPosition :: !GlobalPosition - , emitIndex :: !Int - , targetStreamName :: !StreamName - , errorClass :: !Text - , errorDetail :: !Text - , attemptCount :: !Int - , createdAt :: !UTCTime - } - deriving stock (Generic, Eq, Show) + { deadLetterId :: !Int64, + dispatcherKind :: !DispatcherKind, + dispatcherName :: !Text, + correlationId :: !Text, + sourceEventId :: !EventId, + sourceGlobalPosition :: !GlobalPosition, + emitIndex :: !Int, + targetStreamName :: !StreamName, + errorClass :: !Text, + errorDetail :: !Text, + attemptCount :: !Int, + createdAt :: !UTCTime + } + deriving stock (Generic, Eq, Show) -{- | Insert a rejected dispatch inside the caller's transaction. Redelivery is -idempotent: a duplicate @(dispatcher_name, source_event_id, emit_index)@ is a -no-op. Error detail is bounded here so every caller gets the same 1024-character -storage contract. --} +-- | Insert a rejected dispatch inside the caller's transaction. Redelivery is +-- idempotent: a duplicate @(dispatcher_name, source_event_id, emit_index)@ is a +-- no-op. Error detail is bounded here so every caller gets the same 1024-character +-- storage contract. recordDispatchDeadLetterTx :: DispatchDeadLetter -> Tx.Transaction () recordDispatchDeadLetterTx deadLetter = - Tx.statement (dispatchDeadLetterParams deadLetter) insertDispatchDeadLetterStmt + Tx.statement (dispatchDeadLetterParams deadLetter) insertDispatchDeadLetterStmt -- | List one dispatcher's records, newest first. listDispatchDeadLettersTx :: Text -> Tx.Transaction [DispatchDeadLetterRecord] listDispatchDeadLettersTx dispatcher = - Tx.statement dispatcher listDispatchDeadLettersStmt + Tx.statement dispatcher listDispatchDeadLettersStmt insertDispatchDeadLetterStmt :: Statement (Text, Text, Text, UUID, Int64, Int32, Text, Text, Text, Int32) () insertDispatchDeadLetterStmt = - preparable - """ - INSERT INTO keiro.keiro_dead_letters - (dispatcher_kind, dispatcher_name, correlation_id, source_event_id, - source_global_position, emit_index, target_stream_name, error_class, - error_detail, attempt_count) - VALUES - ($1, $2, $3, $4, $5, $6, $7, $8, $9, $10) - ON CONFLICT (dispatcher_name, source_event_id, emit_index) DO NOTHING - """ - ( contrazip10 - (E.param (E.nonNullable E.text)) - (E.param (E.nonNullable E.text)) - (E.param (E.nonNullable E.text)) - (E.param (E.nonNullable E.uuid)) - (E.param (E.nonNullable E.int8)) - (E.param (E.nonNullable E.int4)) - (E.param (E.nonNullable E.text)) - (E.param (E.nonNullable E.text)) - (E.param (E.nonNullable E.text)) - (E.param (E.nonNullable E.int4)) - ) - D.noResult + preparable + """ + INSERT INTO keiro.keiro_dead_letters + (dispatcher_kind, dispatcher_name, correlation_id, source_event_id, + source_global_position, emit_index, target_stream_name, error_class, + error_detail, attempt_count) + VALUES + ($1, $2, $3, $4, $5, $6, $7, $8, $9, $10) + ON CONFLICT (dispatcher_name, source_event_id, emit_index) DO NOTHING + """ + ( contrazip10 + (E.param (E.nonNullable E.text)) + (E.param (E.nonNullable E.text)) + (E.param (E.nonNullable E.text)) + (E.param (E.nonNullable E.uuid)) + (E.param (E.nonNullable E.int8)) + (E.param (E.nonNullable E.int4)) + (E.param (E.nonNullable E.text)) + (E.param (E.nonNullable E.text)) + (E.param (E.nonNullable E.text)) + (E.param (E.nonNullable E.int4)) + ) + D.noResult listDispatchDeadLettersStmt :: Statement Text [DispatchDeadLetterRecord] listDispatchDeadLettersStmt = - preparable - """ - SELECT dead_letter_id, dispatcher_kind, dispatcher_name, correlation_id, - source_event_id, source_global_position, emit_index, - target_stream_name, error_class, error_detail, attempt_count, - created_at - FROM keiro.keiro_dead_letters - WHERE dispatcher_name = $1 - ORDER BY created_at DESC, dead_letter_id DESC - """ - (E.param (E.nonNullable E.text)) - (D.rowList dispatchDeadLetterRecordDecoder) + preparable + """ + SELECT dead_letter_id, dispatcher_kind, dispatcher_name, correlation_id, + source_event_id, source_global_position, emit_index, + target_stream_name, error_class, error_detail, attempt_count, + created_at + FROM keiro.keiro_dead_letters + WHERE dispatcher_name = $1 + ORDER BY created_at DESC, dead_letter_id DESC + """ + (E.param (E.nonNullable E.text)) + (D.rowList dispatchDeadLetterRecordDecoder) dispatchDeadLetterRecordDecoder :: D.Row DispatchDeadLetterRecord dispatchDeadLetterRecordDecoder = - DispatchDeadLetterRecord - <$> D.column (D.nonNullable D.int8) - <*> D.column (D.nonNullable (D.refine dispatcherKindFromText D.text)) - <*> D.column (D.nonNullable D.text) - <*> D.column (D.nonNullable D.text) - <*> (EventId <$> D.column (D.nonNullable D.uuid)) - <*> (GlobalPosition <$> D.column (D.nonNullable D.int8)) - <*> (fromIntegral <$> D.column (D.nonNullable D.int4)) - <*> (StreamName <$> D.column (D.nonNullable D.text)) - <*> D.column (D.nonNullable D.text) - <*> D.column (D.nonNullable D.text) - <*> (fromIntegral <$> D.column (D.nonNullable D.int4)) - <*> D.column (D.nonNullable D.timestamptz) + DispatchDeadLetterRecord + <$> D.column (D.nonNullable D.int8) + <*> D.column (D.nonNullable (D.refine dispatcherKindFromText D.text)) + <*> D.column (D.nonNullable D.text) + <*> D.column (D.nonNullable D.text) + <*> (EventId <$> D.column (D.nonNullable D.uuid)) + <*> (GlobalPosition <$> D.column (D.nonNullable D.int8)) + <*> (fromIntegral <$> D.column (D.nonNullable D.int4)) + <*> (StreamName <$> D.column (D.nonNullable D.text)) + <*> D.column (D.nonNullable D.text) + <*> D.column (D.nonNullable D.text) + <*> (fromIntegral <$> D.column (D.nonNullable D.int4)) + <*> D.column (D.nonNullable D.timestamptz) dispatchDeadLetterParams :: DispatchDeadLetter -> (Text, Text, Text, UUID, Int64, Int32, Text, Text, Text, Int32) dispatchDeadLetterParams deadLetter = - ( dispatcherKindToText (deadLetter ^. #dispatcherKind) - , deadLetter ^. #dispatcherName - , deadLetter ^. #correlationId - , eventIdToUuid (deadLetter ^. #sourceEventId) - , globalPositionToInt64 (deadLetter ^. #sourceGlobalPosition) - , fromIntegral (deadLetter ^. #emitIndex) - , streamNameToText (deadLetter ^. #targetStreamName) - , deadLetter ^. #errorClass - , Text.take 1024 (deadLetter ^. #errorDetail) - , fromIntegral (deadLetter ^. #attemptCount) - ) + ( dispatcherKindToText (deadLetter ^. #dispatcherKind), + deadLetter ^. #dispatcherName, + deadLetter ^. #correlationId, + eventIdToUuid (deadLetter ^. #sourceEventId), + globalPositionToInt64 (deadLetter ^. #sourceGlobalPosition), + fromIntegral (deadLetter ^. #emitIndex), + streamNameToText (deadLetter ^. #targetStreamName), + deadLetter ^. #errorClass, + Text.take 1024 (deadLetter ^. #errorDetail), + fromIntegral (deadLetter ^. #attemptCount) + ) dispatcherKindToText :: DispatcherKind -> Text dispatcherKindToText = \case - DispatcherProcessManager -> "process-manager" - DispatcherRouter -> "router" + DispatcherProcessManager -> "process-manager" + DispatcherRouter -> "router" dispatcherKindFromText :: Text -> Either Text DispatcherKind dispatcherKindFromText = \case - "process-manager" -> Right DispatcherProcessManager - "router" -> Right DispatcherRouter - other -> Left ("unknown keiro_dead_letters.dispatcher_kind: " <> other) + "process-manager" -> Right DispatcherProcessManager + "router" -> Right DispatcherRouter + other -> Left ("unknown keiro_dead_letters.dispatcher_kind: " <> other) eventIdToUuid :: EventId -> UUID eventIdToUuid (EventId uuid) = uuid diff --git a/src/Keiro/Inbox.hs b/src/Keiro/Inbox.hs --- a/src/Keiro/Inbox.hs +++ b/src/Keiro/Inbox.hs @@ -1,28 +1,27 @@ -{- | Idempotent inbox for cross-bounded-context integration events. - -The inbox lives in the consuming bounded context. When a Kafka consumer -receives an integration event, the inbox records the event's stable -external identity and runs the local handler in the same Postgres -transaction. Duplicate redeliveries (Kafka offset retry, rebalance, -producer republish) become observable as duplicates instead of -re-running the handler. - -The wrapper is a single-transaction primitive: the completed inbox row -and the handler's local writes commit atomically. If the handler raises -or condemns the transaction, the inbox row never appears and the next -delivery starts fresh. - -Completed-row retention defines the deduplication window. After -'garbageCollectCompleted' removes a row, a later delivery of the same key is -processed again. A concurrent GC can also delete a conflicting completed row -between the insert attempt and its lookup; the handler then commits without a -replacement deduplication row, so a later redelivery can run it again. These -cases preserve at-least-once delivery, not permanent exactly-once processing; -size retention beyond the maximum redelivery delay and keep handlers -idempotent. --} -module Keiro.Inbox ( - -- * Re-exports +-- | Idempotent inbox for cross-bounded-context integration events. +-- +-- The inbox lives in the consuming bounded context. When a Kafka consumer +-- receives an integration event, the inbox records the event's stable +-- external identity and runs the local handler in the same Postgres +-- transaction. Duplicate redeliveries (Kafka offset retry, rebalance, +-- producer republish) become observable as duplicates instead of +-- re-running the handler. +-- +-- The wrapper is a single-transaction primitive: the completed inbox row +-- and the handler's local writes commit atomically. If the handler raises +-- or condemns the transaction, the inbox row never appears and the next +-- delivery starts fresh. +-- +-- Completed-row retention defines the deduplication window. After +-- 'garbageCollectCompleted' removes a row, a later delivery of the same key is +-- processed again. A concurrent GC can also delete a conflicting completed row +-- between the insert attempt and its lookup; the handler then commits without a +-- replacement deduplication row, so a later redelivery can run it again. These +-- cases preserve at-least-once delivery, not permanent exactly-once processing; +-- size retention beyond the maximum redelivery delay and keep handlers +-- idempotent. +module Keiro.Inbox + ( -- * Re-exports module Keiro.Inbox.Types, -- * Storage primitives @@ -41,7 +40,7 @@ runInboxTransactionWithRetriesKey, runInboxTransactionBatch, sampleInboxBacklog, -) + ) where import Data.Map.Strict qualified as Map @@ -53,374 +52,368 @@ import Keiro.Inbox.Types import Keiro.Integration.Event (IntegrationEvent) import Keiro.Prelude -import Keiro.Telemetry ( - KeiroMetrics, +import Keiro.Telemetry + ( KeiroMetrics, recordInboxBacklog, recordInboxDuplicates, recordInboxFailed, recordInboxPoisoned, recordInboxProcessed, - ) + ) import Kiroku.Store.Effect (Store) import Kiroku.Store.Transaction (runTransaction) import "hasql-transaction" Hasql.Transaction qualified as Tx data BatchPlan - = BatchKeyError !InboxError - | BatchDuplicate - | BatchWork !Text !Text !IntegrationEvent !(Maybe KafkaDeliveryRef) - -{- | Run @handler@ at most once for each @(source, dedupe_key)@. - -Computes the dedupe key from @policy@ and @kafka@, then in one -transaction: - -* Inserts the inbox row with status @completed@. -* If the row already exists, branches on its status: 'InboxCompleted' - → 'InboxDuplicate'; 'InboxProcessing' → 'InboxInProgress'; - 'InboxFailed' → 'InboxPreviouslyFailed'. -* Otherwise runs @handler@; the row commits only if the handler succeeds. + = BatchKeyError !InboxError + | BatchDuplicate + | BatchWork !Text !Text !IntegrationEvent !(Maybe KafkaDeliveryRef) -The handler is invoked with the decoded 'IntegrationEvent' so it does -not need to redecode bytes. On exception or 'Tx.condemn' the whole -transaction rolls back, including the inbox row insert — the next -delivery sees no row and can retry. --} +-- | Run @handler@ at most once for each @(source, dedupe_key)@. +-- +-- Computes the dedupe key from @policy@ and @kafka@, then in one +-- transaction: +-- +-- * Inserts the inbox row with status @completed@. +-- * If the row already exists, branches on its status: 'InboxCompleted' +-- → 'InboxDuplicate'; 'InboxProcessing' → 'InboxInProgress'; +-- 'InboxFailed' → 'InboxPreviouslyFailed'. +-- * Otherwise runs @handler@; the row commits only if the handler succeeds. +-- +-- The handler is invoked with the decoded 'IntegrationEvent' so it does +-- not need to redecode bytes. On exception or 'Tx.condemn' the whole +-- transaction rolls back, including the inbox row insert — the next +-- delivery sees no row and can retry. runInboxTransaction :: - forall a es. - (IOE :> es, Store :> es) => - Maybe KeiroMetrics -> - InboxDedupePolicy -> - IntegrationEvent -> - Maybe KafkaDeliveryRef -> - (IntegrationEvent -> Tx.Transaction a) -> - Eff es (Either InboxError (InboxResult a)) + forall a es. + (IOE :> es, Store :> es) => + Maybe KeiroMetrics -> + InboxDedupePolicy -> + IntegrationEvent -> + Maybe KafkaDeliveryRef -> + (IntegrationEvent -> Tx.Transaction a) -> + Eff es (Either InboxError (InboxResult a)) runInboxTransaction mMetrics policy event kafka handler = - runInboxTransactionWith mMetrics PersistFullEnvelope policy event kafka handler - -{- | Variant of 'runInboxTransaction' that controls success-path -envelope persistence. + runInboxTransactionWith mMetrics PersistFullEnvelope policy event kafka handler -'PersistDedupeOnly' keeps enough columns for dedupe and operator -correlation but stores an empty payload and omits schema, trace, and -attribute columns for successfully processed rows. --} +-- | Variant of 'runInboxTransaction' that controls success-path +-- envelope persistence. +-- +-- 'PersistDedupeOnly' keeps enough columns for dedupe and operator +-- correlation but stores an empty payload and omits schema, trace, and +-- attribute columns for successfully processed rows. runInboxTransactionWith :: - forall a es. - (IOE :> es, Store :> es) => - Maybe KeiroMetrics -> - InboxPersistence -> - InboxDedupePolicy -> - IntegrationEvent -> - Maybe KafkaDeliveryRef -> - (IntegrationEvent -> Tx.Transaction a) -> - Eff es (Either InboxError (InboxResult a)) + forall a es. + (IOE :> es, Store :> es) => + Maybe KeiroMetrics -> + InboxPersistence -> + InboxDedupePolicy -> + IntegrationEvent -> + Maybe KafkaDeliveryRef -> + (IntegrationEvent -> Tx.Transaction a) -> + Eff es (Either InboxError (InboxResult a)) runInboxTransactionWith mMetrics persistence policy event kafka handler = - case dedupeKeyFor policy event kafka of - Left err -> pure (Left err) - Right dedupe -> - Right - <$> runInboxTransactionWithKeyPersist - mMetrics - persistence - (event ^. #source) - dedupe - event - kafka - handler - -{- | Lower-level variant that takes the dedupe key directly. + case dedupeKeyFor policy event kafka of + Left err -> pure (Left err) + Right dedupe -> + Right + <$> runInboxTransactionWithKeyPersist + mMetrics + persistence + (event ^. #source) + dedupe + event + kafka + handler -Use when the policy is not enough to express the identity scheme — for -example, when the consumer joins fields from multiple headers or -derives the key from the payload itself. --} +-- | Lower-level variant that takes the dedupe key directly. +-- +-- Use when the policy is not enough to express the identity scheme — for +-- example, when the consumer joins fields from multiple headers or +-- derives the key from the payload itself. runInboxTransactionWithKey :: - forall a es. - (IOE :> es, Store :> es) => - Maybe KeiroMetrics -> - Text -> - Text -> - IntegrationEvent -> - Maybe KafkaDeliveryRef -> - (IntegrationEvent -> Tx.Transaction a) -> - Eff es (InboxResult a) + forall a es. + (IOE :> es, Store :> es) => + Maybe KeiroMetrics -> + Text -> + Text -> + IntegrationEvent -> + Maybe KafkaDeliveryRef -> + (IntegrationEvent -> Tx.Transaction a) -> + Eff es (InboxResult a) runInboxTransactionWithKey mMetrics src dedupe event kafka handler = - runInboxTransactionWithKeyPersist mMetrics PersistFullEnvelope src dedupe event kafka handler + runInboxTransactionWithKeyPersist mMetrics PersistFullEnvelope src dedupe event kafka handler runInboxTransactionWithKeyPersist :: - forall a es. - (IOE :> es, Store :> es) => - Maybe KeiroMetrics -> - InboxPersistence -> - Text -> - Text -> - IntegrationEvent -> - Maybe KafkaDeliveryRef -> - (IntegrationEvent -> Tx.Transaction a) -> - Eff es (InboxResult a) + forall a es. + (IOE :> es, Store :> es) => + Maybe KeiroMetrics -> + InboxPersistence -> + Text -> + Text -> + IntegrationEvent -> + Maybe KafkaDeliveryRef -> + (IntegrationEvent -> Tx.Transaction a) -> + Eff es (InboxResult a) runInboxTransactionWithKeyPersist mMetrics persistence src dedupe event kafka handler = do - now <- liftIO getCurrentTime - result <- - runTransaction $ - attemptOneTx persistence Nothing src dedupe event kafka now handler - -- Record the classification counter outside the handler transaction. - -- Backlog gauge sampling is intentionally scheduled separately via - -- 'sampleInboxBacklog'. - recordInboxResult mMetrics Nothing result - pure result - -{- | Run @handler@ with opt-in poison-message accounting. - -This wrapper behaves like 'runInboxTransaction' for fresh messages, -duplicates, and in-flight rows, but changes the behavior for handler -exceptions and previously failed rows: - -* A synchronous exception from @handler@ rolls back the handler - transaction, then records a failed attempt in a second transaction and - returns 'InboxHandlerFailed' with the new attempt count. -* A previously failed row with @attempt_count < ceiling@ is retried. -* A previously failed row with @attempt_count >= ceiling@ returns - 'InboxPreviouslyFailed' without running the handler. The consumer can - commit its offset and move on; the failed inbox row is the dead-letter - record for operator review. + now <- liftIO getCurrentTime + result <- + runTransaction $ + attemptOneTx persistence Nothing src dedupe event kafka now handler + -- Record the classification counter outside the handler transaction. + -- Backlog gauge sampling is intentionally scheduled separately via + -- 'sampleInboxBacklog'. + recordInboxResult mMetrics Nothing result + pure result -'Tx.condemn' is not treated as a handler failure by this wrapper. It -keeps the original rollback semantics from 'runInboxTransaction'. --} +-- | Run @handler@ with opt-in poison-message accounting. +-- +-- This wrapper behaves like 'runInboxTransaction' for fresh messages, +-- duplicates, and in-flight rows, but changes the behavior for handler +-- exceptions and previously failed rows: +-- +-- * A synchronous exception from @handler@ rolls back the handler +-- transaction, then records a failed attempt in a second transaction and +-- returns 'InboxHandlerFailed' with the new attempt count. +-- * A previously failed row with @attempt_count < ceiling@ is retried. +-- * A previously failed row with @attempt_count >= ceiling@ returns +-- 'InboxPreviouslyFailed' without running the handler. The consumer can +-- commit its offset and move on; the failed inbox row is the dead-letter +-- record for operator review. +-- +-- 'Tx.condemn' is not treated as a handler failure by this wrapper. It +-- keeps the original rollback semantics from 'runInboxTransaction'. runInboxTransactionWithRetries :: - forall a es. - (IOE :> es, Store :> es) => - Maybe KeiroMetrics -> - Int -> - InboxDedupePolicy -> - IntegrationEvent -> - Maybe KafkaDeliveryRef -> - (IntegrationEvent -> Tx.Transaction a) -> - Eff es (Either InboxError (InboxResult a)) + forall a es. + (IOE :> es, Store :> es) => + Maybe KeiroMetrics -> + Int -> + InboxDedupePolicy -> + IntegrationEvent -> + Maybe KafkaDeliveryRef -> + (IntegrationEvent -> Tx.Transaction a) -> + Eff es (Either InboxError (InboxResult a)) runInboxTransactionWithRetries mMetrics attemptCeiling policy event kafka handler = - runInboxTransactionWithRetriesWith mMetrics attemptCeiling PersistFullEnvelope policy event kafka handler + runInboxTransactionWithRetriesWith mMetrics attemptCeiling PersistFullEnvelope policy event kafka handler -- | Variant of 'runInboxTransactionWithRetries' that controls success-path persistence. runInboxTransactionWithRetriesWith :: - forall a es. - (IOE :> es, Store :> es) => - Maybe KeiroMetrics -> - Int -> - InboxPersistence -> - InboxDedupePolicy -> - IntegrationEvent -> - Maybe KafkaDeliveryRef -> - (IntegrationEvent -> Tx.Transaction a) -> - Eff es (Either InboxError (InboxResult a)) + forall a es. + (IOE :> es, Store :> es) => + Maybe KeiroMetrics -> + Int -> + InboxPersistence -> + InboxDedupePolicy -> + IntegrationEvent -> + Maybe KafkaDeliveryRef -> + (IntegrationEvent -> Tx.Transaction a) -> + Eff es (Either InboxError (InboxResult a)) runInboxTransactionWithRetriesWith mMetrics attemptCeiling persistence policy event kafka handler = - case dedupeKeyFor policy event kafka of - Left err -> pure (Left err) - Right dedupe -> - Right - <$> runInboxTransactionWithRetriesKeyPersist - mMetrics - attemptCeiling - persistence - (event ^. #source) - dedupe - event - kafka - handler + case dedupeKeyFor policy event kafka of + Left err -> pure (Left err) + Right dedupe -> + Right + <$> runInboxTransactionWithRetriesKeyPersist + mMetrics + attemptCeiling + persistence + (event ^. #source) + dedupe + event + kafka + handler -- | Lower-level retrying variant that takes the dedupe key directly. runInboxTransactionWithRetriesKey :: - forall a es. - (IOE :> es, Store :> es) => - Maybe KeiroMetrics -> - Int -> - Text -> - Text -> - IntegrationEvent -> - Maybe KafkaDeliveryRef -> - (IntegrationEvent -> Tx.Transaction a) -> - Eff es (InboxResult a) + forall a es. + (IOE :> es, Store :> es) => + Maybe KeiroMetrics -> + Int -> + Text -> + Text -> + IntegrationEvent -> + Maybe KafkaDeliveryRef -> + (IntegrationEvent -> Tx.Transaction a) -> + Eff es (InboxResult a) runInboxTransactionWithRetriesKey mMetrics attemptCeiling src dedupe event kafka handler = - runInboxTransactionWithRetriesKeyPersist mMetrics attemptCeiling PersistFullEnvelope src dedupe event kafka handler + runInboxTransactionWithRetriesKeyPersist mMetrics attemptCeiling PersistFullEnvelope src dedupe event kafka handler runInboxTransactionWithRetriesKeyPersist :: - forall a es. - (IOE :> es, Store :> es) => - Maybe KeiroMetrics -> - Int -> - InboxPersistence -> - Text -> - Text -> - IntegrationEvent -> - Maybe KafkaDeliveryRef -> - (IntegrationEvent -> Tx.Transaction a) -> - Eff es (InboxResult a) + forall a es. + (IOE :> es, Store :> es) => + Maybe KeiroMetrics -> + Int -> + InboxPersistence -> + Text -> + Text -> + IntegrationEvent -> + Maybe KafkaDeliveryRef -> + (IntegrationEvent -> Tx.Transaction a) -> + Eff es (InboxResult a) runInboxTransactionWithRetriesKeyPersist mMetrics attemptCeiling persistence src dedupe event kafka handler = do - now <- liftIO getCurrentTime - attempted <- - trySync $ - runTransaction $ - attemptOneTx persistence (Just attemptCeiling) src dedupe event kafka now handler - result <- case attempted of - Right ok -> pure ok - Left err -> do - failedAt <- liftIO getCurrentTime - let errMsg = Text.pack (displayException err) - attempts <- - runTransaction $ - recordFailedAttemptTx src dedupe event kafka errMsg failedAt - pure (InboxHandlerFailed errMsg attempts) - recordInboxResult mMetrics (Just attemptCeiling) result - pure result - -{- | Process a batch of inbox deliveries with a single transactional fast path. - -The fast path computes each @(source, dedupe_key)@, suppresses repeated -keys within the batch as duplicates, then runs all remaining deliveries -in one Postgres transaction. If any handler throws or condemns that -transaction, the whole batch rolls back and every original delivery is -retried through 'runInboxTransactionWithRetries'. That fallback preserves -per-message failure accounting and prevents one poison message from -discarding unrelated batch mates. + now <- liftIO getCurrentTime + attempted <- + trySync $ + runTransaction $ + attemptOneTx persistence (Just attemptCeiling) src dedupe event kafka now handler + result <- case attempted of + Right ok -> pure ok + Left err -> do + failedAt <- liftIO getCurrentTime + let errMsg = Text.pack (displayException err) + attempts <- + runTransaction $ + recordFailedAttemptTx src dedupe event kafka errMsg failedAt + pure (InboxHandlerFailed errMsg attempts) + recordInboxResult mMetrics (Just attemptCeiling) result + pure result -'Tx.condemn' rolls the transaction back at commit but returns normally, -so it cannot be observed from the transaction's return value alone. -The batch detects it by re-reading one row it should have committed: -every write in the fast path belongs to a delivery classified -'InboxProcessed' (fresh insert as @completed@ or retry promotion to -@completed@), so if the first such row is not @completed@ after the -transaction returns, the whole batch was condemned and the per-message -fallback runs. A batch with no 'InboxProcessed' rows performed no writes, -so a condemned transaction loses nothing. --} +-- | Process a batch of inbox deliveries with a single transactional fast path. +-- +-- The fast path computes each @(source, dedupe_key)@, suppresses repeated +-- keys within the batch as duplicates, then runs all remaining deliveries +-- in one Postgres transaction. If any handler throws or condemns that +-- transaction, the whole batch rolls back and every original delivery is +-- retried through 'runInboxTransactionWithRetries'. That fallback preserves +-- per-message failure accounting and prevents one poison message from +-- discarding unrelated batch mates. +-- +-- 'Tx.condemn' rolls the transaction back at commit but returns normally, +-- so it cannot be observed from the transaction's return value alone. +-- The batch detects it by re-reading one row it should have committed: +-- every write in the fast path belongs to a delivery classified +-- 'InboxProcessed' (fresh insert as @completed@ or retry promotion to +-- @completed@), so if the first such row is not @completed@ after the +-- transaction returns, the whole batch was condemned and the per-message +-- fallback runs. A batch with no 'InboxProcessed' rows performed no writes, +-- so a condemned transaction loses nothing. runInboxTransactionBatch :: - forall a es. - (IOE :> es, Store :> es) => - Maybe KeiroMetrics -> - Int -> - InboxDedupePolicy -> - InboxPersistence -> - [(IntegrationEvent, Maybe KafkaDeliveryRef)] -> - (IntegrationEvent -> Tx.Transaction a) -> - Eff es [Either InboxError (InboxResult a)] + forall a es. + (IOE :> es, Store :> es) => + Maybe KeiroMetrics -> + Int -> + InboxDedupePolicy -> + InboxPersistence -> + [(IntegrationEvent, Maybe KafkaDeliveryRef)] -> + (IntegrationEvent -> Tx.Transaction a) -> + Eff es [Either InboxError (InboxResult a)] runInboxTransactionBatch mMetrics attemptCeiling policy persistence deliveries handler = do - now <- liftIO getCurrentTime - let plan = planInboxBatch policy deliveries - attempted <- - trySync $ - runTransaction $ - traverse - ( \case - BatchKeyError err -> pure (Left err) - BatchDuplicate -> pure (Right InboxDuplicate) - BatchWork src dedupe event kafka -> - Right <$> attemptOneTx persistence (Just attemptCeiling) src dedupe event kafka now handler - ) - plan - case attempted of - Right results -> do - committed <- verifyBatchCommitted plan results - if committed - then do - for_ results $ \case - Right result -> recordInboxResult mMetrics (Just attemptCeiling) result - Left _ -> pure () - pure results - else perMessageFallback - Left _ -> perMessageFallback + now <- liftIO getCurrentTime + let plan = planInboxBatch policy deliveries + attempted <- + trySync $ + runTransaction $ + traverse + ( \case + BatchKeyError err -> pure (Left err) + BatchDuplicate -> pure (Right InboxDuplicate) + BatchWork src dedupe event kafka -> + Right <$> attemptOneTx persistence (Just attemptCeiling) src dedupe event kafka now handler + ) + plan + case attempted of + Right results -> do + committed <- verifyBatchCommitted plan results + if committed + then do + for_ results $ \case + Right result -> recordInboxResult mMetrics (Just attemptCeiling) result + Left _ -> pure () + pure results + else perMessageFallback + Left _ -> perMessageFallback where perMessageFallback :: Eff es [Either InboxError (InboxResult a)] perMessageFallback = - traverse - ( \(event, kafka) -> - runInboxTransactionWithRetriesWith mMetrics attemptCeiling persistence policy event kafka handler - ) - deliveries + traverse + ( \(event, kafka) -> + runInboxTransactionWithRetriesWith mMetrics attemptCeiling persistence policy event kafka handler + ) + deliveries -- A condemned transaction returns its results normally but commits -- nothing. Re-read the first row the batch claims to have completed; -- if it is not @completed@, the transaction rolled back at commit. verifyBatchCommitted :: - [BatchPlan] -> - [Either InboxError (InboxResult a)] -> - Eff es Bool + [BatchPlan] -> + [Either InboxError (InboxResult a)] -> + Eff es Bool verifyBatchCommitted plan results = - case listToMaybe (mapMaybe processedKey (zip plan results)) of - Nothing -> pure True - Just (src, dedupe) -> do - row <- lookupInbox src dedupe - pure (fmap (^. #status) row == Just InboxCompleted) + case listToMaybe (mapMaybe processedKey (zip plan results)) of + Nothing -> pure True + Just (src, dedupe) -> do + row <- lookupInbox src dedupe + pure (fmap (^. #status) row == Just InboxCompleted) processedKey :: (BatchPlan, Either InboxError (InboxResult a)) -> Maybe (Text, Text) processedKey = \case - (BatchWork src dedupe _ _, Right (InboxProcessed _)) -> Just (src, dedupe) - _ -> Nothing + (BatchWork src dedupe _ _, Right (InboxProcessed _)) -> Just (src, dedupe) + _ -> Nothing attemptOneTx :: - InboxPersistence -> - Maybe Int -> - Text -> - Text -> - IntegrationEvent -> - Maybe KafkaDeliveryRef -> - UTCTime -> - (IntegrationEvent -> Tx.Transaction a) -> - Tx.Transaction (InboxResult a) + InboxPersistence -> + Maybe Int -> + Text -> + Text -> + IntegrationEvent -> + Maybe KafkaDeliveryRef -> + UTCTime -> + (IntegrationEvent -> Tx.Transaction a) -> + Tx.Transaction (InboxResult a) attemptOneTx persistence attemptCeiling src dedupe event kafka now handler = do - inserted <- tryInsertCompletedTx persistence src dedupe event kafka now - case inserted of - Right () -> do - handled <- handler event - pure (InboxProcessed handled) - Left row -> case row ^. #status of - InboxCompleted -> pure InboxDuplicate - InboxProcessing -> pure InboxInProgress - InboxFailed -> case attemptCeiling of - Nothing -> pure (InboxPreviouslyFailed (row ^. #lastError)) - Just attemptLimit - | row ^. #attemptCount >= attemptLimit -> - pure (InboxPreviouslyFailed (row ^. #lastError)) - | otherwise -> do - handled <- handler event - markCompletedTx src dedupe now - pure (InboxProcessed handled) + inserted <- tryInsertCompletedTx persistence src dedupe event kafka now + case inserted of + Right () -> do + handled <- handler event + pure (InboxProcessed handled) + Left row -> case row ^. #status of + InboxCompleted -> pure InboxDuplicate + InboxProcessing -> pure InboxInProgress + InboxFailed -> case attemptCeiling of + Nothing -> pure (InboxPreviouslyFailed (row ^. #lastError)) + Just attemptLimit + | row ^. #attemptCount >= attemptLimit -> + pure (InboxPreviouslyFailed (row ^. #lastError)) + | otherwise -> do + handled <- handler event + markCompletedTx src dedupe now + pure (InboxProcessed handled) recordInboxResult :: (IOE :> es) => Maybe KeiroMetrics -> Maybe Int -> InboxResult a -> Eff es () recordInboxResult mMetrics attemptCeiling = \case - InboxProcessed _ -> recordInboxProcessed mMetrics 1 - InboxDuplicate -> recordInboxDuplicates mMetrics 1 - InboxPreviouslyFailed _ -> recordInboxFailed mMetrics 1 - InboxHandlerFailed _ attempts -> do - recordInboxFailed mMetrics 1 - case attemptCeiling of - Just attemptLimit | attempts >= attemptLimit -> recordInboxPoisoned mMetrics 1 - _ -> pure () - InboxInProgress -> pure () + InboxProcessed _ -> recordInboxProcessed mMetrics 1 + InboxDuplicate -> recordInboxDuplicates mMetrics 1 + InboxPreviouslyFailed _ -> recordInboxFailed mMetrics 1 + InboxHandlerFailed _ attempts -> do + recordInboxFailed mMetrics 1 + case attemptCeiling of + Just attemptLimit | attempts >= attemptLimit -> recordInboxPoisoned mMetrics 1 + _ -> pure () + InboxInProgress -> pure () planInboxBatch :: - InboxDedupePolicy -> - [(IntegrationEvent, Maybe KafkaDeliveryRef)] -> - [BatchPlan] + InboxDedupePolicy -> + [(IntegrationEvent, Maybe KafkaDeliveryRef)] -> + [BatchPlan] planInboxBatch policy = go Map.empty where go _ [] = [] go seen ((event, kafka) : rest) = - case dedupeKeyFor policy event kafka of - Left err -> BatchKeyError err : go seen rest - Right dedupe -> - let key = (event ^. #source, dedupe) - in if Map.member key seen - then BatchDuplicate : go seen rest - else BatchWork (event ^. #source) dedupe event kafka : go (Map.insert key () seen) rest - -{- | Count the inbox backlog and record the gauge when metrics are enabled. + case dedupeKeyFor policy event kafka of + Left err -> BatchKeyError err : go seen rest + Right dedupe -> + let key = (event ^. #source, dedupe) + in if Map.member key seen + then BatchDuplicate : go seen rest + else BatchWork (event ^. #source) dedupe event kafka : go (Map.insert key () seen) rest -The backlog is non-terminal rows: legacy @processing@ rows plus failed rows. -Schedule this on its own interval; it is intentionally not part of the -per-message intake path. --} +-- | Count the inbox backlog and record the gauge when metrics are enabled. +-- +-- The backlog is non-terminal rows: legacy @processing@ rows plus failed rows. +-- Schedule this on its own interval; it is intentionally not part of the +-- per-message intake path. sampleInboxBacklog :: (IOE :> es, Store :> es) => Maybe KeiroMetrics -> Eff es () sampleInboxBacklog Nothing = pure () sampleInboxBacklog (Just metrics) = do - backlog <- countInboxBacklog - recordInboxBacklog (Just metrics) (fromIntegral backlog) + backlog <- countInboxBacklog + recordInboxBacklog (Just metrics) (fromIntegral backlog) diff --git a/src/Keiro/Inbox/Kafka.hs b/src/Keiro/Inbox/Kafka.hs --- a/src/Keiro/Inbox/Kafka.hs +++ b/src/Keiro/Inbox/Kafka.hs @@ -1,21 +1,20 @@ -{- | Reconstruct an 'IntegrationEvent' from Kafka payload bytes plus -headers. - -This module is the receiving-side counterpart of -'Keiro.Outbox.Kafka.integrationEventToKafkaRecord'. It is pure: the -caller supplies the bytes and the @Text@-keyed header map produced by -its Kafka adapter, and gets back a decoded envelope or a typed error. - -@keiro@ itself does not depend on @hw-kafka-client@ or -@shibuya-kafka-adapter@; the consumer adapter in EP-22 bridges the -broker library's header type to @[(Text, Text)]@ before calling -'integrationEventFromKafka'. --} -module Keiro.Inbox.Kafka ( - KafkaInboundRecord (..), +-- | Reconstruct an 'IntegrationEvent' from Kafka payload bytes plus +-- headers. +-- +-- This module is the receiving-side counterpart of +-- 'Keiro.Outbox.Kafka.integrationEventToKafkaRecord'. It is pure: the +-- caller supplies the bytes and the @Text@-keyed header map produced by +-- its Kafka adapter, and gets back a decoded envelope or a typed error. +-- +-- @keiro@ itself does not depend on @hw-kafka-client@ or +-- @shibuya-kafka-adapter@; the consumer adapter in EP-22 bridges the +-- broker library's header type to @[(Text, Text)]@ before calling +-- 'integrationEventFromKafka'. +module Keiro.Inbox.Kafka + ( KafkaInboundRecord (..), KafkaDecodeError (..), integrationEventFromKafka, -) + ) where import Data.Aeson qualified as Aeson @@ -27,8 +26,8 @@ import Data.Time.Format.ISO8601 (iso8601ParseM) import Data.UUID qualified as UUID import Keiro.Inbox.Types (KafkaDeliveryRef (..)) -import Keiro.Integration.Event ( - IntegrationContentType (..), +import Keiro.Integration.Event + ( IntegrationContentType (..), IntegrationEvent (..), SchemaReference (..), TraceContext (..), @@ -52,93 +51,91 @@ headerTraceParent, headerTraceState, parseContentType, - ) + ) import Keiro.Prelude import Kiroku.Store.Types (EventId (..), GlobalPosition (..)) -{- | A Kafka record as seen by the consumer-side adapter, decoupled from -the broker library's record type. --} +-- | A Kafka record as seen by the consumer-side adapter, decoupled from +-- the broker library's record type. data KafkaInboundRecord = KafkaInboundRecord - { topic :: !Text - , partition :: !Int64 - , offset :: !Int64 - , key :: !(Maybe Text) - , payload :: !ByteString - , headers :: ![(Text, Text)] - , receivedAt :: !UTCTime - } - deriving stock (Generic, Eq, Show) + { topic :: !Text, + partition :: !Int64, + offset :: !Int64, + key :: !(Maybe Text), + payload :: !ByteString, + headers :: ![(Text, Text)], + receivedAt :: !UTCTime + } + deriving stock (Generic, Eq, Show) -- | Typed failures from 'integrationEventFromKafka'. data KafkaDecodeError - = MissingHeader !Text - | InvalidIntHeader !Text !Text - | InvalidUuidHeader !Text !Text - | InvalidTimeHeader !Text !Text - | InvalidJsonHeader !Text !Text - deriving stock (Generic, Eq, Show) - -{- | Reconstruct a full 'IntegrationEvent' plus the 'KafkaDeliveryRef' -recorded for diagnostics. + = MissingHeader !Text + | InvalidIntHeader !Text !Text + | InvalidUuidHeader !Text !Text + | InvalidTimeHeader !Text !Text + | InvalidJsonHeader !Text !Text + deriving stock (Generic, Eq, Show) -The reconstruction is faithful to the canonical header names defined -by 'Keiro.Integration.Event' (e.g. @keiro-message-id@, @keiro-source@, -@traceparent@). Missing required headers (@keiro-source@, -@keiro-destination@, @keiro-event-type@, @keiro-schema-version@, -@content-type@, @keiro-message-id@) produce 'MissingHeader'; malformed -numeric or UUID headers produce 'InvalidIntHeader' / 'InvalidUuidHeader'. -Optional headers are silently absent in the resulting envelope. --} +-- | Reconstruct a full 'IntegrationEvent' plus the 'KafkaDeliveryRef' +-- recorded for diagnostics. +-- +-- The reconstruction is faithful to the canonical header names defined +-- by 'Keiro.Integration.Event' (e.g. @keiro-message-id@, @keiro-source@, +-- @traceparent@). Missing required headers (@keiro-source@, +-- @keiro-destination@, @keiro-event-type@, @keiro-schema-version@, +-- @content-type@, @keiro-message-id@) produce 'MissingHeader'; malformed +-- numeric or UUID headers produce 'InvalidIntHeader' / 'InvalidUuidHeader'. +-- Optional headers are silently absent in the resulting envelope. integrationEventFromKafka :: - KafkaInboundRecord -> - Either KafkaDecodeError (IntegrationEvent, KafkaDeliveryRef) + KafkaInboundRecord -> + Either KafkaDecodeError (IntegrationEvent, KafkaDeliveryRef) integrationEventFromKafka record = do - let hs = record ^. #headers - source <- requireHeader hs headerSource - destination <- requireHeader hs headerDestination - eventType <- requireHeader hs headerEventType - schemaVersionText <- requireHeader hs headerSchemaVersion - schemaVersion <- parseInt headerSchemaVersion schemaVersionText - contentTypeRaw <- requireHeader hs headerContentType - messageId <- requireHeader hs headerMessageId - schemaReference <- buildSchemaReference hs - sourceEventId <- traverseLookup hs headerSourceEventId (fmap EventId . parseUuid headerSourceEventId) - sourceGlobalPosition <- - traverseLookup hs headerSourceGlobalPosition (fmap GlobalPosition . parseInt headerSourceGlobalPosition) - causationId <- traverseLookup hs headerCausationId (fmap EventId . parseUuid headerCausationId) - correlationId <- traverseLookup hs headerCorrelationId (fmap EventId . parseUuid headerCorrelationId) - occurredAt <- fromMaybe (record ^. #receivedAt) <$> traverseLookup hs headerOccurredAt (parseTimeHeader headerOccurredAt) - attributes <- traverseLookup hs headerAttributes (parseJsonHeader headerAttributes) - let traceContext = case Prelude.lookup headerTraceParent hs of - Nothing -> Nothing - Just tp -> Just (TraceContext tp (Prelude.lookup headerTraceState hs)) - event = - IntegrationEvent - { messageId - , source - , destination - , key = record ^. #key - , eventType - , schemaVersion - , contentType = parseContentType contentTypeRaw - , schemaReference - , sourceEventId - , sourceGlobalPosition - , payloadBytes = record ^. #payload - , occurredAt - , causationId - , correlationId - , traceContext - , attributes - } - kafka = - KafkaDeliveryRef - { topic = record ^. #topic - , partition = record ^. #partition - , offset = record ^. #offset - } - pure (event, kafka) + let hs = record ^. #headers + source <- requireHeader hs headerSource + destination <- requireHeader hs headerDestination + eventType <- requireHeader hs headerEventType + schemaVersionText <- requireHeader hs headerSchemaVersion + schemaVersion <- parseInt headerSchemaVersion schemaVersionText + contentTypeRaw <- requireHeader hs headerContentType + messageId <- requireHeader hs headerMessageId + schemaReference <- buildSchemaReference hs + sourceEventId <- traverseLookup hs headerSourceEventId (fmap EventId . parseUuid headerSourceEventId) + sourceGlobalPosition <- + traverseLookup hs headerSourceGlobalPosition (fmap GlobalPosition . parseInt headerSourceGlobalPosition) + causationId <- traverseLookup hs headerCausationId (fmap EventId . parseUuid headerCausationId) + correlationId <- traverseLookup hs headerCorrelationId (fmap EventId . parseUuid headerCorrelationId) + occurredAt <- fromMaybe (record ^. #receivedAt) <$> traverseLookup hs headerOccurredAt (parseTimeHeader headerOccurredAt) + attributes <- traverseLookup hs headerAttributes (parseJsonHeader headerAttributes) + let traceContext = case Prelude.lookup headerTraceParent hs of + Nothing -> Nothing + Just tp -> Just (TraceContext tp (Prelude.lookup headerTraceState hs)) + event = + IntegrationEvent + { messageId, + source, + destination, + key = record ^. #key, + eventType, + schemaVersion, + contentType = parseContentType contentTypeRaw, + schemaReference, + sourceEventId, + sourceGlobalPosition, + payloadBytes = record ^. #payload, + occurredAt, + causationId, + correlationId, + traceContext, + attributes + } + kafka = + KafkaDeliveryRef + { topic = record ^. #topic, + partition = record ^. #partition, + offset = record ^. #offset + } + pure (event, kafka) -- --------------------------------------------------------------------------- -- Helpers @@ -146,67 +143,66 @@ requireHeader :: [(Text, Text)] -> Text -> Either KafkaDecodeError Text requireHeader hs name = case Prelude.lookup name hs of - Just v -> Right v - Nothing -> Left (MissingHeader name) + Just v -> Right v + Nothing -> Left (MissingHeader name) traverseLookup :: - [(Text, Text)] -> - Text -> - (Text -> Either KafkaDecodeError a) -> - Either KafkaDecodeError (Maybe a) + [(Text, Text)] -> + Text -> + (Text -> Either KafkaDecodeError a) -> + Either KafkaDecodeError (Maybe a) traverseLookup hs name parser = case Prelude.lookup name hs of - Nothing -> Right Nothing - Just raw -> fmap Just (parser raw) + Nothing -> Right Nothing + Just raw -> fmap Just (parser raw) parseInt :: (Integral a) => Text -> Text -> Either KafkaDecodeError a parseInt name raw = case TextRead.signed TextRead.decimal raw of - Right (n, rest) | Text.null rest -> Right n - _ -> Left (InvalidIntHeader name raw) + Right (n, rest) | Text.null rest -> Right n + _ -> Left (InvalidIntHeader name raw) parseUuid :: Text -> Text -> Either KafkaDecodeError UUID.UUID parseUuid name raw = case UUID.fromText raw of - Just u -> Right u - Nothing -> Left (InvalidUuidHeader name raw) + Just u -> Right u + Nothing -> Left (InvalidUuidHeader name raw) parseTimeHeader :: Text -> Text -> Either KafkaDecodeError UTCTime parseTimeHeader name raw = - maybe (Left (InvalidTimeHeader name raw)) Right (iso8601ParseM (Text.unpack raw)) + maybe (Left (InvalidTimeHeader name raw)) Right (iso8601ParseM (Text.unpack raw)) parseJsonHeader :: Text -> Text -> Either KafkaDecodeError Value parseJsonHeader name raw = - case Aeson.eitherDecodeStrict (TextEncoding.encodeUtf8 raw) of - Right value -> Right value - Left _ -> Left (InvalidJsonHeader name raw) + case Aeson.eitherDecodeStrict (TextEncoding.encodeUtf8 raw) of + Right value -> Right value + Left _ -> Left (InvalidJsonHeader name raw) buildSchemaReference :: - [(Text, Text)] -> - Either KafkaDecodeError (Maybe SchemaReference) + [(Text, Text)] -> + Either KafkaDecodeError (Maybe SchemaReference) buildSchemaReference hs = do - let registry = Prelude.lookup headerSchemaRegistry hs - subject = Prelude.lookup headerSchemaSubject hs - fingerprint = Prelude.lookup headerSchemaFingerprint hs - versionRef <- traverseLookup hs headerSchemaVersionRef (parseInt headerSchemaVersionRef) - schemaId <- traverseLookup hs headerSchemaId (parseInt headerSchemaId) - let presentFields = - mapMaybe id [registry, subject, fmap (Text.pack . show) versionRef, fmap (Text.pack . show) schemaId, fingerprint] - if null presentFields - then pure Nothing - else - pure - ( Just - ( SchemaReference - { registry - , subject - , version = versionRef - , schemaId - , fingerprint - } - ) - ) + let registry = Prelude.lookup headerSchemaRegistry hs + subject = Prelude.lookup headerSchemaSubject hs + fingerprint = Prelude.lookup headerSchemaFingerprint hs + versionRef <- traverseLookup hs headerSchemaVersionRef (parseInt headerSchemaVersionRef) + schemaId <- traverseLookup hs headerSchemaId (parseInt headerSchemaId) + let presentFields = + mapMaybe id [registry, subject, fmap (Text.pack . show) versionRef, fmap (Text.pack . show) schemaId, fingerprint] + if null presentFields + then pure Nothing + else + pure + ( Just + ( SchemaReference + { registry, + subject, + version = versionRef, + schemaId, + fingerprint + } + ) + ) -{- | Silence unused-import warning when 'IntegrationContentType' is -imported only via the open re-export but referenced through -'parseContentType'. --} +-- | Silence unused-import warning when 'IntegrationContentType' is +-- imported only via the open re-export but referenced through +-- 'parseContentType'. _unusedKeepContentType :: IntegrationContentType -> () _unusedKeepContentType _ = () diff --git a/src/Keiro/Inbox/Schema.hs b/src/Keiro/Inbox/Schema.hs --- a/src/Keiro/Inbox/Schema.hs +++ b/src/Keiro/Inbox/Schema.hs @@ -1,13 +1,12 @@ {-# LANGUAGE ApplicativeDo #-} -{- | Hasql-level storage for the idempotent integration-event inbox. - -This module owns the SQL surface that the inbox wrapper -('Keiro.Inbox.runInboxTransaction') and the optional Kafka decoder -('Keiro.Inbox.Kafka') consume. --} -module Keiro.Inbox.Schema ( - tryInsertCompletedTx, +-- | Hasql-level storage for the idempotent integration-event inbox. +-- +-- This module owns the SQL surface that the inbox wrapper +-- ('Keiro.Inbox.runInboxTransaction') and the optional Kafka decoder +-- ('Keiro.Inbox.Kafka') consume. +module Keiro.Inbox.Schema + ( tryInsertCompletedTx, markCompletedTx, markFailedTx, recordFailedAttemptTx, @@ -15,7 +14,7 @@ listInbox, garbageCollectCompleted, countInboxBacklog, -) + ) where import Contravariant.Extras (contrazip2, contrazip3, contrazip4) @@ -29,226 +28,222 @@ import Hasql.Encoders qualified as E import Hasql.Statement (Statement, preparable) import Keiro.Inbox.Types -import Keiro.Integration.Event ( - IntegrationEvent (..), +import Keiro.Integration.Event + ( IntegrationEvent (..), SchemaReference (..), TraceContext (..), contentTypeText, parseContentType, - ) + ) import Keiro.Prelude import Kiroku.Store.Effect (Store) import Kiroku.Store.Transaction (runTransaction) import Kiroku.Store.Types (EventId (..), GlobalPosition (..)) import "hasql-transaction" Hasql.Transaction qualified as Tx -{- | Attempt to insert a new completed row. - -Returns 'Left' carrying the existing row if @(source, dedupe_key)@ -already exists; returns 'Right ()' if the insert created a new row. The -caller — typically 'Keiro.Inbox.runInboxTransaction' — then either runs -the handler (new) or branches on the existing row's status (duplicate). - -The row is inserted as @completed@ before the handler runs, but remains -uncommitted until the handler transaction succeeds. On handler failure the -whole transaction rolls back, so the completed row never becomes visible. - -If a concurrent retention job deletes the conflicting row between the -insert attempt and the lookup, this returns 'Right ()'. The handler's effects -then commit without a replacement deduplication row, and a later redelivery -can run the handler again. This preserves at-least-once delivery but not -permanent exactly-once processing. Retention must exceed the maximum tolerated -redelivery delay, and handlers must remain idempotent. --} +-- | Attempt to insert a new completed row. +-- +-- Returns 'Left' carrying the existing row if @(source, dedupe_key)@ +-- already exists; returns 'Right ()' if the insert created a new row. The +-- caller — typically 'Keiro.Inbox.runInboxTransaction' — then either runs +-- the handler (new) or branches on the existing row's status (duplicate). +-- +-- The row is inserted as @completed@ before the handler runs, but remains +-- uncommitted until the handler transaction succeeds. On handler failure the +-- whole transaction rolls back, so the completed row never becomes visible. +-- +-- If a concurrent retention job deletes the conflicting row between the +-- insert attempt and the lookup, this returns 'Right ()'. The handler's effects +-- then commit without a replacement deduplication row, and a later redelivery +-- can run the handler again. This preserves at-least-once delivery but not +-- permanent exactly-once processing. Retention must exceed the maximum tolerated +-- redelivery delay, and handlers must remain idempotent. tryInsertCompletedTx :: - InboxPersistence -> - Text -> - Text -> - IntegrationEvent -> - Maybe KafkaDeliveryRef -> - UTCTime -> - Tx.Transaction (Either InboxRow ()) + InboxPersistence -> + Text -> + Text -> + IntegrationEvent -> + Maybe KafkaDeliveryRef -> + UTCTime -> + Tx.Transaction (Either InboxRow ()) tryInsertCompletedTx persistence src dedupe event kafka now = do - inserted <- - Tx.statement (toEncodedInsert persistence src dedupe event kafka now) tryInsertStmt - if inserted - then pure (Right ()) - else do - existing <- Tx.statement (src, dedupe) selectByKeyStmt - case existing of - Just row -> pure (Left row) - Nothing -> pure (Right ()) + inserted <- + Tx.statement (toEncodedInsert persistence src dedupe event kafka now) tryInsertStmt + if inserted + then pure (Right ()) + else do + existing <- Tx.statement (src, dedupe) selectByKeyStmt + case existing of + Just row -> pure (Left row) + Nothing -> pure (Right ()) -- | Mark an inbox row completed inside the same transaction as the handler. markCompletedTx :: Text -> Text -> UTCTime -> Tx.Transaction () markCompletedTx src dedupe now = - Tx.statement (src, dedupe, now) markCompletedStmt + Tx.statement (src, dedupe, now) markCompletedStmt -- | Mark an inbox row failed inside the same transaction as the handler. markFailedTx :: Text -> Text -> Text -> UTCTime -> Tx.Transaction () markFailedTx src dedupe errMsg now = - Tx.statement (src, dedupe, errMsg, now) markFailedStmt - -{- | Record one failed handler attempt for @(source, dedupe_key)@. + Tx.statement (src, dedupe, errMsg, now) markFailedStmt -Creates a failed row when the handler transaction rolled back the initial -processing insert, or increments the existing failed row's attempt count. -Returns the new attempt count. --} +-- | Record one failed handler attempt for @(source, dedupe_key)@. +-- +-- Creates a failed row when the handler transaction rolled back the initial +-- processing insert, or increments the existing failed row's attempt count. +-- Returns the new attempt count. recordFailedAttemptTx :: - Text -> - Text -> - IntegrationEvent -> - Maybe KafkaDeliveryRef -> - Text -> - UTCTime -> - Tx.Transaction Int + Text -> + Text -> + IntegrationEvent -> + Maybe KafkaDeliveryRef -> + Text -> + UTCTime -> + Tx.Transaction Int recordFailedAttemptTx src dedupe event kafka errMsg now = - Tx.statement (toEncodedFailedInsert src dedupe event kafka errMsg now) recordFailedAttemptStmt + Tx.statement (toEncodedFailedInsert src dedupe event kafka errMsg now) recordFailedAttemptStmt -- | Read one inbox row. lookupInbox :: (Store :> es) => Text -> Text -> Eff es (Maybe InboxRow) lookupInbox src dedupe = - runTransaction $ - Tx.statement (src, dedupe) selectByKeyStmt + runTransaction $ + Tx.statement (src, dedupe) selectByKeyStmt -- | List inbox rows for a source, ordered by @received_at@. Test helper. listInbox :: (Store :> es) => Text -> Eff es [InboxRow] listInbox src = - runTransaction $ - Tx.statement src listBySourceStmt - -{- | Count inbox rows in a non-terminal state (backlog gauge source). + runTransaction $ + Tx.statement src listBySourceStmt -Backlog = rows still @processing@ (in flight) or @failed@ (awaiting a -retry decision). Completed rows are terminal and excluded. --} +-- | Count inbox rows in a non-terminal state (backlog gauge source). +-- +-- Backlog = rows still @processing@ (in flight) or @failed@ (awaiting a +-- retry decision). Completed rows are terminal and excluded. countInboxBacklog :: (Store :> es) => Eff es Int countInboxBacklog = - runTransaction (Tx.statement () countInboxBacklogStmt) - -{- | Delete completed inbox rows older than @keepFor@ from @now@. + runTransaction (Tx.statement () countInboxBacklogStmt) -Returns the number of rows deleted. The retention window defines the -duplicate-detection window: a redelivery that arrives after retention -GC has run will be processed again, so the window must exceed the -maximum delivery delay tolerated by the operator. The user guide -recommends 30 days as a default. See 'tryInsertCompletedTx' for the related -concurrent-GC race and its at-least-once consequence. --} +-- | Delete completed inbox rows older than @keepFor@ from @now@. +-- +-- Returns the number of rows deleted. The retention window defines the +-- duplicate-detection window: a redelivery that arrives after retention +-- GC has run will be processed again, so the window must exceed the +-- maximum delivery delay tolerated by the operator. The user guide +-- recommends 30 days as a default. See 'tryInsertCompletedTx' for the related +-- concurrent-GC race and its at-least-once consequence. garbageCollectCompleted :: - (Store :> es) => - NominalDiffTime -> - UTCTime -> - Eff es Int + (Store :> es) => + NominalDiffTime -> + UTCTime -> + Eff es Int garbageCollectCompleted keepFor now = do - let cutoff = addUTCTime (negate keepFor) now - result <- - runTransaction $ - Tx.statement cutoff gcStmt - pure (fromIntegral result) + let cutoff = addUTCTime (negate keepFor) now + result <- + runTransaction $ + Tx.statement cutoff gcStmt + pure (fromIntegral result) -- --------------------------------------------------------------------------- -- Encoder support -- --------------------------------------------------------------------------- data EncodedInsert = EncodedInsert - { source :: !Text - , dedupeKey :: !Text - , messageId :: !(Maybe Text) - , sourceEventId :: !(Maybe UUID) - , sourceGlobalPosition :: !(Maybe Int64) - , destination :: !(Maybe Text) - , eventType :: !(Maybe Text) - , schemaVersion :: !(Maybe Int64) - , contentType :: !Text - , schemaRegistry :: !(Maybe Text) - , schemaSubject :: !(Maybe Text) - , schemaVersionRef :: !(Maybe Int64) - , schemaId :: !(Maybe Int64) - , schemaFingerprint :: !(Maybe Text) - , causationId :: !(Maybe UUID) - , correlationId :: !(Maybe UUID) - , traceparent :: !(Maybe Text) - , tracestate :: !(Maybe Text) - , kafkaTopic :: !(Maybe Text) - , kafkaPartition :: !(Maybe Int64) - , kafkaOffset :: !(Maybe Int64) - , payloadBytes :: !ByteString - , attributes :: !(Maybe Value) - , occurredAt :: !(Maybe UTCTime) - , receivedAt :: !UTCTime - } - deriving stock (Generic) + { source :: !Text, + dedupeKey :: !Text, + messageId :: !(Maybe Text), + sourceEventId :: !(Maybe UUID), + sourceGlobalPosition :: !(Maybe Int64), + destination :: !(Maybe Text), + eventType :: !(Maybe Text), + schemaVersion :: !(Maybe Int64), + contentType :: !Text, + schemaRegistry :: !(Maybe Text), + schemaSubject :: !(Maybe Text), + schemaVersionRef :: !(Maybe Int64), + schemaId :: !(Maybe Int64), + schemaFingerprint :: !(Maybe Text), + causationId :: !(Maybe UUID), + correlationId :: !(Maybe UUID), + traceparent :: !(Maybe Text), + tracestate :: !(Maybe Text), + kafkaTopic :: !(Maybe Text), + kafkaPartition :: !(Maybe Int64), + kafkaOffset :: !(Maybe Int64), + payloadBytes :: !ByteString, + attributes :: !(Maybe Value), + occurredAt :: !(Maybe UTCTime), + receivedAt :: !UTCTime + } + deriving stock (Generic) data EncodedFailedInsert = EncodedFailedInsert - { insert :: !EncodedInsert - , lastError :: !Text - } - deriving stock (Generic) + { insert :: !EncodedInsert, + lastError :: !Text + } + deriving stock (Generic) toEncodedInsert :: - InboxPersistence -> - Text -> - Text -> - IntegrationEvent -> - Maybe KafkaDeliveryRef -> - UTCTime -> - EncodedInsert + InboxPersistence -> + Text -> + Text -> + IntegrationEvent -> + Maybe KafkaDeliveryRef -> + UTCTime -> + EncodedInsert toEncodedInsert persistence src dedupe event kafka now = - let mref = event ^. #schemaReference - mtrace = event ^. #traceContext - in EncodedInsert - { source = src - , dedupeKey = dedupe - , messageId = nullIfEmpty (event ^. #messageId) - , sourceEventId = fmap unEventId (event ^. #sourceEventId) - , sourceGlobalPosition = fmap unGlobalPosition (event ^. #sourceGlobalPosition) - , destination = nullIfEmpty (event ^. #destination) - , eventType = nullIfEmpty (event ^. #eventType) - , schemaVersion = persistedSchema (Just (fromIntegral (event ^. #schemaVersion))) - , contentType = contentTypeText (event ^. #contentType) - , schemaRegistry = persistedSchema (mref >>= (^. #registry)) - , schemaSubject = persistedSchema (mref >>= (^. #subject)) - , schemaVersionRef = persistedSchema (fmap fromIntegral (mref >>= (^. #version))) - , schemaId = persistedSchema (mref >>= (^. #schemaId)) - , schemaFingerprint = persistedSchema (mref >>= (^. #fingerprint)) - , causationId = fmap unEventId (event ^. #causationId) - , correlationId = fmap unEventId (event ^. #correlationId) - , traceparent = persistedEnvelope (fmap (^. #traceparent) mtrace) - , tracestate = persistedEnvelope (mtrace >>= (^. #tracestate)) - , kafkaTopic = fmap (^. #topic) kafka - , kafkaPartition = fmap (^. #partition) kafka - , kafkaOffset = fmap (^. #offset) kafka - , payloadBytes = case persistence of - PersistFullEnvelope -> event ^. #payloadBytes - PersistDedupeOnly -> mempty - , attributes = persistedEnvelope (event ^. #attributes) - , occurredAt = Just (event ^. #occurredAt) - , receivedAt = now - } + let mref = event ^. #schemaReference + mtrace = event ^. #traceContext + in EncodedInsert + { source = src, + dedupeKey = dedupe, + messageId = nullIfEmpty (event ^. #messageId), + sourceEventId = fmap unEventId (event ^. #sourceEventId), + sourceGlobalPosition = fmap unGlobalPosition (event ^. #sourceGlobalPosition), + destination = nullIfEmpty (event ^. #destination), + eventType = nullIfEmpty (event ^. #eventType), + schemaVersion = persistedSchema (Just (fromIntegral (event ^. #schemaVersion))), + contentType = contentTypeText (event ^. #contentType), + schemaRegistry = persistedSchema (mref >>= (^. #registry)), + schemaSubject = persistedSchema (mref >>= (^. #subject)), + schemaVersionRef = persistedSchema (fmap fromIntegral (mref >>= (^. #version))), + schemaId = persistedSchema (mref >>= (^. #schemaId)), + schemaFingerprint = persistedSchema (mref >>= (^. #fingerprint)), + causationId = fmap unEventId (event ^. #causationId), + correlationId = fmap unEventId (event ^. #correlationId), + traceparent = persistedEnvelope (fmap (^. #traceparent) mtrace), + tracestate = persistedEnvelope (mtrace >>= (^. #tracestate)), + kafkaTopic = fmap (^. #topic) kafka, + kafkaPartition = fmap (^. #partition) kafka, + kafkaOffset = fmap (^. #offset) kafka, + payloadBytes = case persistence of + PersistFullEnvelope -> event ^. #payloadBytes + PersistDedupeOnly -> mempty, + attributes = persistedEnvelope (event ^. #attributes), + occurredAt = Just (event ^. #occurredAt), + receivedAt = now + } where persistedEnvelope :: Maybe x -> Maybe x persistedEnvelope value = case persistence of - PersistFullEnvelope -> value - PersistDedupeOnly -> Nothing + PersistFullEnvelope -> value + PersistDedupeOnly -> Nothing persistedSchema :: Maybe x -> Maybe x persistedSchema = persistedEnvelope toEncodedFailedInsert :: - Text -> - Text -> - IntegrationEvent -> - Maybe KafkaDeliveryRef -> - Text -> - UTCTime -> - EncodedFailedInsert + Text -> + Text -> + IntegrationEvent -> + Maybe KafkaDeliveryRef -> + Text -> + UTCTime -> + EncodedFailedInsert toEncodedFailedInsert src dedupe event kafka errMsg now = - EncodedFailedInsert - { insert = toEncodedInsert PersistFullEnvelope src dedupe event kafka now - , lastError = errMsg - } + EncodedFailedInsert + { insert = toEncodedInsert PersistFullEnvelope src dedupe event kafka now, + lastError = errMsg + } nullIfEmpty :: Text -> Maybe Text nullIfEmpty t = if t == mempty then Nothing else Just t @@ -261,38 +256,38 @@ encodedInsertEncoder :: E.Params EncodedInsert encodedInsertEncoder = - mconcat - [ view #source >$< E.param (E.nonNullable E.text) - , view #dedupeKey >$< E.param (E.nonNullable E.text) - , view #messageId >$< E.param (E.nullable E.text) - , view #sourceEventId >$< E.param (E.nullable E.uuid) - , view #sourceGlobalPosition >$< E.param (E.nullable E.int8) - , view #destination >$< E.param (E.nullable E.text) - , view #eventType >$< E.param (E.nullable E.text) - , view #schemaVersion >$< E.param (E.nullable E.int8) - , view #contentType >$< E.param (E.nonNullable E.text) - , view #schemaRegistry >$< E.param (E.nullable E.text) - , view #schemaSubject >$< E.param (E.nullable E.text) - , view #schemaVersionRef >$< E.param (E.nullable E.int8) - , view #schemaId >$< E.param (E.nullable E.int8) - , view #schemaFingerprint >$< E.param (E.nullable E.text) - , view #causationId >$< E.param (E.nullable E.uuid) - , view #correlationId >$< E.param (E.nullable E.uuid) - , view #traceparent >$< E.param (E.nullable E.text) - , view #tracestate >$< E.param (E.nullable E.text) - , view #kafkaTopic >$< E.param (E.nullable E.text) - , view #kafkaPartition >$< E.param (E.nullable E.int8) - , view #kafkaOffset >$< E.param (E.nullable E.int8) - , view #payloadBytes >$< E.param (E.nonNullable E.bytea) - , view #attributes >$< E.param (E.nullable E.jsonb) - , view #occurredAt >$< E.param (E.nullable E.timestamptz) - , view #receivedAt >$< E.param (E.nonNullable E.timestamptz) - ] + mconcat + [ view #source >$< E.param (E.nonNullable E.text), + view #dedupeKey >$< E.param (E.nonNullable E.text), + view #messageId >$< E.param (E.nullable E.text), + view #sourceEventId >$< E.param (E.nullable E.uuid), + view #sourceGlobalPosition >$< E.param (E.nullable E.int8), + view #destination >$< E.param (E.nullable E.text), + view #eventType >$< E.param (E.nullable E.text), + view #schemaVersion >$< E.param (E.nullable E.int8), + view #contentType >$< E.param (E.nonNullable E.text), + view #schemaRegistry >$< E.param (E.nullable E.text), + view #schemaSubject >$< E.param (E.nullable E.text), + view #schemaVersionRef >$< E.param (E.nullable E.int8), + view #schemaId >$< E.param (E.nullable E.int8), + view #schemaFingerprint >$< E.param (E.nullable E.text), + view #causationId >$< E.param (E.nullable E.uuid), + view #correlationId >$< E.param (E.nullable E.uuid), + view #traceparent >$< E.param (E.nullable E.text), + view #tracestate >$< E.param (E.nullable E.text), + view #kafkaTopic >$< E.param (E.nullable E.text), + view #kafkaPartition >$< E.param (E.nullable E.int8), + view #kafkaOffset >$< E.param (E.nullable E.int8), + view #payloadBytes >$< E.param (E.nonNullable E.bytea), + view #attributes >$< E.param (E.nullable E.jsonb), + view #occurredAt >$< E.param (E.nullable E.timestamptz), + view #receivedAt >$< E.param (E.nonNullable E.timestamptz) + ] encodedFailedInsertEncoder :: E.Params EncodedFailedInsert encodedFailedInsertEncoder = - (view #insert >$< encodedInsertEncoder) - <> (view #lastError >$< E.param (E.nonNullable E.text)) + (view #insert >$< encodedInsertEncoder) + <> (view #lastError >$< E.param (E.nonNullable E.text)) -- --------------------------------------------------------------------------- -- Statements @@ -300,314 +295,313 @@ tryInsertStmt :: Statement EncodedInsert Bool tryInsertStmt = - preparable - """ - INSERT INTO keiro.keiro_inbox - ( source - , dedupe_key - , message_id - , source_event_id - , source_global_position - , destination - , event_type - , schema_version - , content_type - , schema_registry - , schema_subject - , schema_version_ref - , schema_id - , schema_fingerprint - , causation_id - , correlation_id - , traceparent - , tracestate - , kafka_topic - , kafka_partition - , kafka_offset - , payload_bytes - , attributes - , occurred_at - , received_at - , status - , completed_at - ) - VALUES - ($1, $2, $3, $4, $5, $6, $7, $8, $9, $10, $11, $12, $13, $14, $15, $16, $17, $18, $19, $20, $21, $22, $23, $24, $25, 'completed', $25) - ON CONFLICT (source, dedupe_key) DO NOTHING - RETURNING TRUE - """ - encodedInsertEncoder - (fmap (fromMaybe False) (D.rowMaybe (D.column (D.nonNullable D.bool)))) + preparable + """ + INSERT INTO keiro.keiro_inbox + ( source + , dedupe_key + , message_id + , source_event_id + , source_global_position + , destination + , event_type + , schema_version + , content_type + , schema_registry + , schema_subject + , schema_version_ref + , schema_id + , schema_fingerprint + , causation_id + , correlation_id + , traceparent + , tracestate + , kafka_topic + , kafka_partition + , kafka_offset + , payload_bytes + , attributes + , occurred_at + , received_at + , status + , completed_at + ) + VALUES + ($1, $2, $3, $4, $5, $6, $7, $8, $9, $10, $11, $12, $13, $14, $15, $16, $17, $18, $19, $20, $21, $22, $23, $24, $25, 'completed', $25) + ON CONFLICT (source, dedupe_key) DO NOTHING + RETURNING TRUE + """ + encodedInsertEncoder + (fmap (fromMaybe False) (D.rowMaybe (D.column (D.nonNullable D.bool)))) markCompletedStmt :: Statement (Text, Text, UTCTime) () markCompletedStmt = - preparable - """ - UPDATE keiro.keiro_inbox - SET status = 'completed', - completed_at = $3, - last_error = NULL - WHERE source = $1 AND dedupe_key = $2 - """ - ( contrazip3 - (E.param (E.nonNullable E.text)) - (E.param (E.nonNullable E.text)) - (E.param (E.nonNullable E.timestamptz)) - ) - D.noResult + preparable + """ + UPDATE keiro.keiro_inbox + SET status = 'completed', + completed_at = $3, + last_error = NULL + WHERE source = $1 AND dedupe_key = $2 + """ + ( contrazip3 + (E.param (E.nonNullable E.text)) + (E.param (E.nonNullable E.text)) + (E.param (E.nonNullable E.timestamptz)) + ) + D.noResult markFailedStmt :: Statement (Text, Text, Text, UTCTime) () markFailedStmt = - preparable - """ - UPDATE keiro.keiro_inbox - SET status = 'failed', - failed_at = $4, - last_error = $3 - WHERE source = $1 AND dedupe_key = $2 - """ - ( contrazip4 - (E.param (E.nonNullable E.text)) - (E.param (E.nonNullable E.text)) - (E.param (E.nonNullable E.text)) - (E.param (E.nonNullable E.timestamptz)) - ) - D.noResult + preparable + """ + UPDATE keiro.keiro_inbox + SET status = 'failed', + failed_at = $4, + last_error = $3 + WHERE source = $1 AND dedupe_key = $2 + """ + ( contrazip4 + (E.param (E.nonNullable E.text)) + (E.param (E.nonNullable E.text)) + (E.param (E.nonNullable E.text)) + (E.param (E.nonNullable E.timestamptz)) + ) + D.noResult recordFailedAttemptStmt :: Statement EncodedFailedInsert Int recordFailedAttemptStmt = - preparable - """ - INSERT INTO keiro.keiro_inbox - ( source - , dedupe_key - , message_id - , source_event_id - , source_global_position - , destination - , event_type - , schema_version - , content_type - , schema_registry - , schema_subject - , schema_version_ref - , schema_id - , schema_fingerprint - , causation_id - , correlation_id - , traceparent - , tracestate - , kafka_topic - , kafka_partition - , kafka_offset - , payload_bytes - , attributes - , occurred_at - , received_at - , status - , attempt_count - , failed_at - , last_error - ) - VALUES - ($1, $2, $3, $4, $5, $6, $7, $8, $9, $10, $11, $12, $13, $14, $15, $16, $17, $18, $19, $20, $21, $22, $23, $24, $25, 'failed', 1, $25, $26) - ON CONFLICT (source, dedupe_key) DO UPDATE - SET status = 'failed', - attempt_count = keiro_inbox.attempt_count + 1, - last_error = EXCLUDED.last_error, - failed_at = EXCLUDED.failed_at - RETURNING attempt_count - """ - encodedFailedInsertEncoder - (fmap fromIntegral (D.singleRow (D.column (D.nonNullable D.int8)))) + preparable + """ + INSERT INTO keiro.keiro_inbox + ( source + , dedupe_key + , message_id + , source_event_id + , source_global_position + , destination + , event_type + , schema_version + , content_type + , schema_registry + , schema_subject + , schema_version_ref + , schema_id + , schema_fingerprint + , causation_id + , correlation_id + , traceparent + , tracestate + , kafka_topic + , kafka_partition + , kafka_offset + , payload_bytes + , attributes + , occurred_at + , received_at + , status + , attempt_count + , failed_at + , last_error + ) + VALUES + ($1, $2, $3, $4, $5, $6, $7, $8, $9, $10, $11, $12, $13, $14, $15, $16, $17, $18, $19, $20, $21, $22, $23, $24, $25, 'failed', 1, $25, $26) + ON CONFLICT (source, dedupe_key) DO UPDATE + SET status = 'failed', + attempt_count = keiro_inbox.attempt_count + 1, + last_error = EXCLUDED.last_error, + failed_at = EXCLUDED.failed_at + RETURNING attempt_count + """ + encodedFailedInsertEncoder + (fmap fromIntegral (D.singleRow (D.column (D.nonNullable D.int8)))) selectByKeyStmt :: Statement (Text, Text) (Maybe InboxRow) selectByKeyStmt = - preparable - (selectAllSql <> " WHERE source = $1 AND dedupe_key = $2") - ( contrazip2 - (E.param (E.nonNullable E.text)) - (E.param (E.nonNullable E.text)) - ) - (D.rowMaybe inboxRowDecoder) + preparable + (selectAllSql <> " WHERE source = $1 AND dedupe_key = $2") + ( contrazip2 + (E.param (E.nonNullable E.text)) + (E.param (E.nonNullable E.text)) + ) + (D.rowMaybe inboxRowDecoder) listBySourceStmt :: Statement Text [InboxRow] listBySourceStmt = - preparable - (selectAllSql <> " WHERE source = $1 ORDER BY received_at, dedupe_key") - (E.param (E.nonNullable E.text)) - (D.rowList inboxRowDecoder) + preparable + (selectAllSql <> " WHERE source = $1 ORDER BY received_at, dedupe_key") + (E.param (E.nonNullable E.text)) + (D.rowList inboxRowDecoder) countInboxBacklogStmt :: Statement () Int countInboxBacklogStmt = - preparable - "SELECT COUNT(*)::bigint FROM keiro.keiro_inbox WHERE status IN ('processing', 'failed')" - E.noParams - (fmap fromIntegral (D.singleRow (D.column (D.nonNullable D.int8)))) + preparable + "SELECT COUNT(*)::bigint FROM keiro.keiro_inbox WHERE status IN ('processing', 'failed')" + E.noParams + (fmap fromIntegral (D.singleRow (D.column (D.nonNullable D.int8)))) gcStmt :: Statement UTCTime Int64 gcStmt = - preparable - """ - WITH deleted AS ( - DELETE FROM keiro.keiro_inbox - WHERE status = 'completed' AND completed_at < $1 - RETURNING 1 - ) - SELECT COALESCE(COUNT(*), 0)::bigint FROM deleted - """ - (E.param (E.nonNullable E.timestamptz)) - (D.singleRow (D.column (D.nonNullable D.int8))) + preparable + """ + WITH deleted AS ( + DELETE FROM keiro.keiro_inbox + WHERE status = 'completed' AND completed_at < $1 + RETURNING 1 + ) + SELECT COALESCE(COUNT(*), 0)::bigint FROM deleted + """ + (E.param (E.nonNullable E.timestamptz)) + (D.singleRow (D.column (D.nonNullable D.int8))) selectAllSql :: Text selectAllSql = - """ - SELECT source, dedupe_key, message_id, source_event_id, source_global_position, - destination, event_type, schema_version, content_type, schema_registry, - schema_subject, schema_version_ref, schema_id, schema_fingerprint, - causation_id, correlation_id, traceparent, tracestate, kafka_topic, - kafka_partition, kafka_offset, payload_bytes, attributes, occurred_at, - status, attempt_count, received_at, completed_at, failed_at, last_error - FROM keiro.keiro_inbox - """ + """ + SELECT source, dedupe_key, message_id, source_event_id, source_global_position, + destination, event_type, schema_version, content_type, schema_registry, + schema_subject, schema_version_ref, schema_id, schema_fingerprint, + causation_id, correlation_id, traceparent, tracestate, kafka_topic, + kafka_partition, kafka_offset, payload_bytes, attributes, occurred_at, + status, attempt_count, received_at, completed_at, failed_at, last_error + FROM keiro.keiro_inbox + """ inboxRowDecoder :: D.Row InboxRow inboxRowDecoder = fmap assembleInboxRow rawDecoder data RawInbox = RawInbox - { source :: !Text - , dedupeKey :: !Text - , messageId :: !(Maybe Text) - , sourceEventId :: !(Maybe EventId) - , sourceGlobalPosition :: !(Maybe GlobalPosition) - , destination :: !(Maybe Text) - , eventType :: !(Maybe Text) - , schemaVersion :: !(Maybe Int) - , contentType :: !Text - , schemaRegistry :: !(Maybe Text) - , schemaSubject :: !(Maybe Text) - , schemaVersionRef :: !(Maybe Int) - , schemaId :: !(Maybe Int64) - , schemaFingerprint :: !(Maybe Text) - , causationId :: !(Maybe EventId) - , correlationId :: !(Maybe EventId) - , traceparent :: !(Maybe Text) - , tracestate :: !(Maybe Text) - , kafkaTopic :: !(Maybe Text) - , kafkaPartition :: !(Maybe Int64) - , kafkaOffset :: !(Maybe Int64) - , payloadBytes :: !ByteString - , attributes :: !(Maybe Value) - , occurredAt :: !(Maybe UTCTime) - , status :: !InboxStatus - , attemptCount :: !Int - , receivedAt :: !UTCTime - , completedAt :: !(Maybe UTCTime) - , failedAt :: !(Maybe UTCTime) - , lastError :: !(Maybe Text) - } - deriving stock (Generic) + { source :: !Text, + dedupeKey :: !Text, + messageId :: !(Maybe Text), + sourceEventId :: !(Maybe EventId), + sourceGlobalPosition :: !(Maybe GlobalPosition), + destination :: !(Maybe Text), + eventType :: !(Maybe Text), + schemaVersion :: !(Maybe Int), + contentType :: !Text, + schemaRegistry :: !(Maybe Text), + schemaSubject :: !(Maybe Text), + schemaVersionRef :: !(Maybe Int), + schemaId :: !(Maybe Int64), + schemaFingerprint :: !(Maybe Text), + causationId :: !(Maybe EventId), + correlationId :: !(Maybe EventId), + traceparent :: !(Maybe Text), + tracestate :: !(Maybe Text), + kafkaTopic :: !(Maybe Text), + kafkaPartition :: !(Maybe Int64), + kafkaOffset :: !(Maybe Int64), + payloadBytes :: !ByteString, + attributes :: !(Maybe Value), + occurredAt :: !(Maybe UTCTime), + status :: !InboxStatus, + attemptCount :: !Int, + receivedAt :: !UTCTime, + completedAt :: !(Maybe UTCTime), + failedAt :: !(Maybe UTCTime), + lastError :: !(Maybe Text) + } + deriving stock (Generic) rawDecoder :: D.Row RawInbox rawDecoder = - RawInbox - <$> D.column (D.nonNullable D.text) - <*> D.column (D.nonNullable D.text) - <*> D.column (D.nullable D.text) - <*> (fmap EventId <$> D.column (D.nullable D.uuid)) - <*> (fmap GlobalPosition <$> D.column (D.nullable D.int8)) - <*> D.column (D.nullable D.text) - <*> D.column (D.nullable D.text) - <*> (fmap fromIntegral <$> D.column (D.nullable D.int8)) - <*> D.column (D.nonNullable D.text) - <*> D.column (D.nullable D.text) - <*> D.column (D.nullable D.text) - <*> (fmap fromIntegral <$> D.column (D.nullable D.int8)) - <*> D.column (D.nullable D.int8) - <*> D.column (D.nullable D.text) - <*> (fmap EventId <$> D.column (D.nullable D.uuid)) - <*> (fmap EventId <$> D.column (D.nullable D.uuid)) - <*> D.column (D.nullable D.text) - <*> D.column (D.nullable D.text) - <*> D.column (D.nullable D.text) - <*> D.column (D.nullable D.int8) - <*> D.column (D.nullable D.int8) - <*> D.column (D.nonNullable D.bytea) - <*> D.column (D.nullable D.jsonb) - <*> D.column (D.nullable D.timestamptz) - <*> D.column (D.nonNullable (D.refine parseInboxStatus D.text)) - <*> (fromIntegral <$> D.column (D.nonNullable D.int8)) - <*> D.column (D.nonNullable D.timestamptz) - <*> D.column (D.nullable D.timestamptz) - <*> D.column (D.nullable D.timestamptz) - <*> D.column (D.nullable D.text) + RawInbox + <$> D.column (D.nonNullable D.text) + <*> D.column (D.nonNullable D.text) + <*> D.column (D.nullable D.text) + <*> (fmap EventId <$> D.column (D.nullable D.uuid)) + <*> (fmap GlobalPosition <$> D.column (D.nullable D.int8)) + <*> D.column (D.nullable D.text) + <*> D.column (D.nullable D.text) + <*> (fmap fromIntegral <$> D.column (D.nullable D.int8)) + <*> D.column (D.nonNullable D.text) + <*> D.column (D.nullable D.text) + <*> D.column (D.nullable D.text) + <*> (fmap fromIntegral <$> D.column (D.nullable D.int8)) + <*> D.column (D.nullable D.int8) + <*> D.column (D.nullable D.text) + <*> (fmap EventId <$> D.column (D.nullable D.uuid)) + <*> (fmap EventId <$> D.column (D.nullable D.uuid)) + <*> D.column (D.nullable D.text) + <*> D.column (D.nullable D.text) + <*> D.column (D.nullable D.text) + <*> D.column (D.nullable D.int8) + <*> D.column (D.nullable D.int8) + <*> D.column (D.nonNullable D.bytea) + <*> D.column (D.nullable D.jsonb) + <*> D.column (D.nullable D.timestamptz) + <*> D.column (D.nonNullable (D.refine parseInboxStatus D.text)) + <*> (fromIntegral <$> D.column (D.nonNullable D.int8)) + <*> D.column (D.nonNullable D.timestamptz) + <*> D.column (D.nullable D.timestamptz) + <*> D.column (D.nullable D.timestamptz) + <*> D.column (D.nullable D.text) assembleInboxRow :: RawInbox -> InboxRow assembleInboxRow raw = - let traceContext = case raw ^. #traceparent of - Nothing -> Nothing - Just tp -> Just (TraceContext tp (raw ^. #tracestate)) - schemaReference = - case ( raw ^. #schemaRegistry - , raw ^. #schemaSubject - , raw ^. #schemaVersionRef - , raw ^. #schemaId - , raw ^. #schemaFingerprint - ) of - (Nothing, Nothing, Nothing, Nothing, Nothing) -> Nothing - _ -> - Just - ( SchemaReference - (raw ^. #schemaRegistry) - (raw ^. #schemaSubject) - (raw ^. #schemaVersionRef) - (raw ^. #schemaId) - (raw ^. #schemaFingerprint) - ) - kafka = - case (raw ^. #kafkaTopic, raw ^. #kafkaPartition, raw ^. #kafkaOffset) of - (Just t, Just p, Just o) -> Just (KafkaDeliveryRef t p o) - _ -> Nothing - event = - IntegrationEvent - { messageId = fromMaybe mempty (raw ^. #messageId) - , source = raw ^. #source - , destination = fromMaybe mempty (raw ^. #destination) - , key = Nothing - , -- @key@ is not part of the inbox primary key and is not - -- carried separately on the row — the same partition info - -- lives in @kafka@. Receivers that need it can re-derive - -- from the payload. - eventType = fromMaybe mempty (raw ^. #eventType) - , schemaVersion = fromMaybe 0 (raw ^. #schemaVersion) - , contentType = parseContentType (raw ^. #contentType) - , schemaReference - , sourceEventId = raw ^. #sourceEventId - , sourceGlobalPosition = raw ^. #sourceGlobalPosition - , payloadBytes = raw ^. #payloadBytes - , occurredAt = fromMaybe defaultEpoch (raw ^. #occurredAt) - , causationId = raw ^. #causationId - , correlationId = raw ^. #correlationId - , traceContext - , attributes = raw ^. #attributes - } - in InboxRow - { source = raw ^. #source - , dedupeKey = raw ^. #dedupeKey - , event - , kafka - , status = raw ^. #status - , attemptCount = raw ^. #attemptCount - , receivedAt = raw ^. #receivedAt - , completedAt = raw ^. #completedAt - , failedAt = raw ^. #failedAt - , lastError = raw ^. #lastError - } - -{- | Sentinel used when an inbox row was written without an @occurred_at@. + let traceContext = case raw ^. #traceparent of + Nothing -> Nothing + Just tp -> Just (TraceContext tp (raw ^. #tracestate)) + schemaReference = + case ( raw ^. #schemaRegistry, + raw ^. #schemaSubject, + raw ^. #schemaVersionRef, + raw ^. #schemaId, + raw ^. #schemaFingerprint + ) of + (Nothing, Nothing, Nothing, Nothing, Nothing) -> Nothing + _ -> + Just + ( SchemaReference + (raw ^. #schemaRegistry) + (raw ^. #schemaSubject) + (raw ^. #schemaVersionRef) + (raw ^. #schemaId) + (raw ^. #schemaFingerprint) + ) + kafka = + case (raw ^. #kafkaTopic, raw ^. #kafkaPartition, raw ^. #kafkaOffset) of + (Just t, Just p, Just o) -> Just (KafkaDeliveryRef t p o) + _ -> Nothing + event = + IntegrationEvent + { messageId = fromMaybe mempty (raw ^. #messageId), + source = raw ^. #source, + destination = fromMaybe mempty (raw ^. #destination), + key = Nothing, + -- @key@ is not part of the inbox primary key and is not + -- carried separately on the row — the same partition info + -- lives in @kafka@. Receivers that need it can re-derive + -- from the payload. + eventType = fromMaybe mempty (raw ^. #eventType), + schemaVersion = fromMaybe 0 (raw ^. #schemaVersion), + contentType = parseContentType (raw ^. #contentType), + schemaReference, + sourceEventId = raw ^. #sourceEventId, + sourceGlobalPosition = raw ^. #sourceGlobalPosition, + payloadBytes = raw ^. #payloadBytes, + occurredAt = fromMaybe defaultEpoch (raw ^. #occurredAt), + causationId = raw ^. #causationId, + correlationId = raw ^. #correlationId, + traceContext, + attributes = raw ^. #attributes + } + in InboxRow + { source = raw ^. #source, + dedupeKey = raw ^. #dedupeKey, + event, + kafka, + status = raw ^. #status, + attemptCount = raw ^. #attemptCount, + receivedAt = raw ^. #receivedAt, + completedAt = raw ^. #completedAt, + failedAt = raw ^. #failedAt, + lastError = raw ^. #lastError + } -Inbox rows are observability-shaped; consumers that care should -re-read the timestamp from the envelope payload directly. --} +-- | Sentinel used when an inbox row was written without an @occurred_at@. +-- +-- Inbox rows are observability-shaped; consumers that care should +-- re-read the timestamp from the envelope payload directly. defaultEpoch :: UTCTime defaultEpoch = posixSecondsToUTCTime 0 diff --git a/src/Keiro/Inbox/Types.hs b/src/Keiro/Inbox/Types.hs --- a/src/Keiro/Inbox/Types.hs +++ b/src/Keiro/Inbox/Types.hs @@ -1,14 +1,13 @@ -{- | Shared types for the idempotent integration-event inbox. - -The inbox lives in the consuming bounded context. When a Kafka consumer -receives an integration event, the inbox records a stable external -identity for that message and runs the local handler in the same -transaction. Duplicate redeliveries (Kafka offset retry, rebalance, -producer republish) become observable as duplicates instead of -re-running the handler. --} -module Keiro.Inbox.Types ( - InboxDedupePolicy (..), +-- | Shared types for the idempotent integration-event inbox. +-- +-- The inbox lives in the consuming bounded context. When a Kafka consumer +-- receives an integration event, the inbox records a stable external +-- identity for that message and runs the local handler in the same +-- transaction. Duplicate redeliveries (Kafka offset retry, rebalance, +-- producer republish) become observable as duplicates instead of +-- re-running the handler. +module Keiro.Inbox.Types + ( InboxDedupePolicy (..), InboxPersistence (..), InboxStatus (..), InboxResult (..), @@ -18,7 +17,7 @@ inboxStatusText, parseInboxStatus, dedupeKeyFor, -) + ) where import Data.Text qualified as Text @@ -27,172 +26,164 @@ import Keiro.Prelude import Kiroku.Store.Types (EventId (..), GlobalPosition (..)) -{- | Which identity is used as the inbox primary key for an -'IntegrationEvent'. - -* 'PreferIntegrationMessageId' (default) — use the application-level - @messageId@ minted at the producer's outbox enqueue. EP-19 / EP-20 - keep this id stable across publish retries, so it is the natural - primary dedupe key for Kafka-delivered events. -* 'PreferSourceEventIdentity' — use the @sourceEventId@ of the private - event that produced this integration event. Useful when a producer - may emit the same logical fact under different @messageId@s (e.g. - schema-upgrade republish), and the consumer wants those republishes - collapsed to a single handler run. -* 'KafkaDeliveryIdentity' — use the Kafka topic-partition-offset triple - as the dedupe key. Fallback only when neither @messageId@ nor source - identity is available. This identifies one broker delivery, not one - logical producer message: if a producer republishes the same logical - message, Kafka assigns a new offset and this policy will not collapse - the republish. -* 'CustomDedupeKey' — caller supplies the key. Use only when the other - policies cannot represent the identity scheme; the consuming service - owns key collision resistance. --} +-- | Which identity is used as the inbox primary key for an +-- 'IntegrationEvent'. +-- +-- * 'PreferIntegrationMessageId' (default) — use the application-level +-- @messageId@ minted at the producer's outbox enqueue. EP-19 / EP-20 +-- keep this id stable across publish retries, so it is the natural +-- primary dedupe key for Kafka-delivered events. +-- * 'PreferSourceEventIdentity' — use the @sourceEventId@ of the private +-- event that produced this integration event. Useful when a producer +-- may emit the same logical fact under different @messageId@s (e.g. +-- schema-upgrade republish), and the consumer wants those republishes +-- collapsed to a single handler run. +-- * 'KafkaDeliveryIdentity' — use the Kafka topic-partition-offset triple +-- as the dedupe key. Fallback only when neither @messageId@ nor source +-- identity is available. This identifies one broker delivery, not one +-- logical producer message: if a producer republishes the same logical +-- message, Kafka assigns a new offset and this policy will not collapse +-- the republish. +-- * 'CustomDedupeKey' — caller supplies the key. Use only when the other +-- policies cannot represent the identity scheme; the consuming service +-- owns key collision resistance. data InboxDedupePolicy - = PreferIntegrationMessageId - | PreferSourceEventIdentity - | KafkaDeliveryIdentity - | CustomDedupeKey !Text - deriving stock (Generic, Eq, Show) - -{- | How much of the integration-event envelope the inbox persists on the -success path. + = PreferIntegrationMessageId + | PreferSourceEventIdentity + | KafkaDeliveryIdentity + | CustomDedupeKey !Text + deriving stock (Generic, Eq, Show) -The failure path always persists the full envelope because a failed -inbox row is the operator's dead-letter record. --} +-- | How much of the integration-event envelope the inbox persists on the +-- success path. +-- +-- The failure path always persists the full envelope because a failed +-- inbox row is the operator's dead-letter record. data InboxPersistence - = PersistFullEnvelope - | PersistDedupeOnly - deriving stock (Generic, Eq, Show) - -{- | Lifecycle state of an inbox row. + = PersistFullEnvelope + | PersistDedupeOnly + deriving stock (Generic, Eq, Show) -* 'InboxProcessing' — legacy on-disk state from older wrappers and - reserved for future async paths. Current single-transaction intake - inserts fresh successful rows directly as 'InboxCompleted'. -* 'InboxCompleted' — handler ran to completion; terminal. -* 'InboxFailed' — handler signaled a permanent failure; terminal. The - caller is responsible for operator action (dead-letter, manual - retry). --} +-- | Lifecycle state of an inbox row. +-- +-- * 'InboxProcessing' — legacy on-disk state from older wrappers and +-- reserved for future async paths. Current single-transaction intake +-- inserts fresh successful rows directly as 'InboxCompleted'. +-- * 'InboxCompleted' — handler ran to completion; terminal. +-- * 'InboxFailed' — handler signaled a permanent failure; terminal. The +-- caller is responsible for operator action (dead-letter, manual +-- retry). data InboxStatus - = InboxProcessing - | InboxCompleted - | InboxFailed - deriving stock (Generic, Eq, Show) - -{- | The classified outcome of 'Keiro.Inbox.runInboxTransaction'. + = InboxProcessing + | InboxCompleted + | InboxFailed + deriving stock (Generic, Eq, Show) -* 'InboxProcessed a' — first delivery; handler ran and returned @a@. -* 'InboxDuplicate' — a previous delivery already completed; handler not - run. -* 'InboxInProgress' — a previous attempt is currently in-flight, or a - legacy @processing@ row was read. Current single-transaction intake - does not commit @processing@ rows. Treat as transient. -* 'InboxPreviouslyFailed' — a previous attempt recorded a permanent - failure. Operator should review before reprocessing. --} +-- | The classified outcome of 'Keiro.Inbox.runInboxTransaction'. +-- +-- * 'InboxProcessed a' — first delivery; handler ran and returned @a@. +-- * 'InboxDuplicate' — a previous delivery already completed; handler not +-- run. +-- * 'InboxInProgress' — a previous attempt is currently in-flight, or a +-- legacy @processing@ row was read. Current single-transaction intake +-- does not commit @processing@ rows. Treat as transient. +-- * 'InboxPreviouslyFailed' — a previous attempt recorded a permanent +-- failure. Operator should review before reprocessing. data InboxResult a - = InboxProcessed !a - | InboxDuplicate - | InboxInProgress - | InboxPreviouslyFailed !(Maybe Text) - | InboxHandlerFailed !Text !Int - deriving stock (Generic, Eq, Show) + = InboxProcessed !a + | InboxDuplicate + | InboxInProgress + | InboxPreviouslyFailed !(Maybe Text) + | InboxHandlerFailed !Text !Int + deriving stock (Generic, Eq, Show) -{- | Errors surfaced by the inbox wrapper that originate from the inbox -itself rather than from the supplied handler. --} +-- | Errors surfaced by the inbox wrapper that originate from the inbox +-- itself rather than from the supplied handler. data InboxError - = -- | The integration event lacked the field required by the chosen policy. - DedupePolicyUnsatisfied !InboxDedupePolicy - deriving stock (Generic, Eq, Show) - -{- | Optional Kafka-delivery metadata recorded alongside an inbox row. + = -- | The integration event lacked the field required by the chosen policy. + DedupePolicyUnsatisfied !InboxDedupePolicy + deriving stock (Generic, Eq, Show) -Used by 'KafkaDeliveryIdentity' to compute the dedupe key, and stored on -the row regardless of policy so operators can correlate the inbox -record with Kafka logs. Not part of the EP-19 envelope. --} +-- | Optional Kafka-delivery metadata recorded alongside an inbox row. +-- +-- Used by 'KafkaDeliveryIdentity' to compute the dedupe key, and stored on +-- the row regardless of policy so operators can correlate the inbox +-- record with Kafka logs. Not part of the EP-19 envelope. data KafkaDeliveryRef = KafkaDeliveryRef - { topic :: !Text - , partition :: !Int64 - , offset :: !Int64 - } - deriving stock (Generic, Eq, Show) - -{- | One row read back from @keiro_inbox@. + { topic :: !Text, + partition :: !Int64, + offset :: !Int64 + } + deriving stock (Generic, Eq, Show) -Rows written with 'PersistDedupeOnly' decode with an empty -'IntegrationEvent' @payloadBytes@, no attributes, no trace context, and -no schema reference. Identity, routing, source-event ids, occurrence -time, and Kafka delivery metadata are still preserved. --} +-- | One row read back from @keiro_inbox@. +-- +-- Rows written with 'PersistDedupeOnly' decode with an empty +-- 'IntegrationEvent' @payloadBytes@, no attributes, no trace context, and +-- no schema reference. Identity, routing, source-event ids, occurrence +-- time, and Kafka delivery metadata are still preserved. data InboxRow = InboxRow - { source :: !Text - , dedupeKey :: !Text - , event :: !IntegrationEvent - , kafka :: !(Maybe KafkaDeliveryRef) - , status :: !InboxStatus - , attemptCount :: !Int - , receivedAt :: !UTCTime - , completedAt :: !(Maybe UTCTime) - , failedAt :: !(Maybe UTCTime) - , lastError :: !(Maybe Text) - } - deriving stock (Generic, Eq, Show) + { source :: !Text, + dedupeKey :: !Text, + event :: !IntegrationEvent, + kafka :: !(Maybe KafkaDeliveryRef), + status :: !InboxStatus, + attemptCount :: !Int, + receivedAt :: !UTCTime, + completedAt :: !(Maybe UTCTime), + failedAt :: !(Maybe UTCTime), + lastError :: !(Maybe Text) + } + deriving stock (Generic, Eq, Show) inboxStatusText :: InboxStatus -> Text inboxStatusText = \case - InboxProcessing -> "processing" - InboxCompleted -> "completed" - InboxFailed -> "failed" + InboxProcessing -> "processing" + InboxCompleted -> "completed" + InboxFailed -> "failed" parseInboxStatus :: Text -> Either Text InboxStatus parseInboxStatus = \case - "processing" -> Right InboxProcessing - "completed" -> Right InboxCompleted - "failed" -> Right InboxFailed - other -> Left ("unknown keiro_inbox.status: " <> other) + "processing" -> Right InboxProcessing + "completed" -> Right InboxCompleted + "failed" -> Right InboxFailed + other -> Left ("unknown keiro_inbox.status: " <> other) -{- | Compute the inbox dedupe key for an integration event under the -given policy plus optional Kafka delivery context. Returns 'Left' when -the policy demands a field the envelope does not carry (for example, -'PreferSourceEventIdentity' on an envelope with no -@sourceEventId@). --} +-- | Compute the inbox dedupe key for an integration event under the +-- given policy plus optional Kafka delivery context. Returns 'Left' when +-- the policy demands a field the envelope does not carry (for example, +-- 'PreferSourceEventIdentity' on an envelope with no +-- @sourceEventId@). dedupeKeyFor :: - InboxDedupePolicy -> - IntegrationEvent -> - Maybe KafkaDeliveryRef -> - Either InboxError Text + InboxDedupePolicy -> + IntegrationEvent -> + Maybe KafkaDeliveryRef -> + Either InboxError Text dedupeKeyFor policy event kafka = case policy of - PreferIntegrationMessageId -> - let mid = event ^. #messageId - in if Text.null mid - then Left (DedupePolicyUnsatisfied policy) - else Right mid - PreferSourceEventIdentity -> - case event ^. #sourceEventId of - Just (EventId u) -> Right (UUID.toText u) - Nothing -> - case event ^. #sourceGlobalPosition of - Just (GlobalPosition p) -> Right (Text.pack (show p)) - Nothing -> Left (DedupePolicyUnsatisfied policy) - KafkaDeliveryIdentity -> - case kafka of - Just ref -> - Right - ( (ref ^. #topic) - <> ":" - <> Text.pack (show (ref ^. #partition)) - <> ":" - <> Text.pack (show (ref ^. #offset)) - ) - Nothing -> Left (DedupePolicyUnsatisfied policy) - CustomDedupeKey k -> - if Text.null k - then Left (DedupePolicyUnsatisfied policy) - else Right k + PreferIntegrationMessageId -> + let mid = event ^. #messageId + in if Text.null mid + then Left (DedupePolicyUnsatisfied policy) + else Right mid + PreferSourceEventIdentity -> + case event ^. #sourceEventId of + Just (EventId u) -> Right (UUID.toText u) + Nothing -> + case event ^. #sourceGlobalPosition of + Just (GlobalPosition p) -> Right (Text.pack (show p)) + Nothing -> Left (DedupePolicyUnsatisfied policy) + KafkaDeliveryIdentity -> + case kafka of + Just ref -> + Right + ( (ref ^. #topic) + <> ":" + <> Text.pack (show (ref ^. #partition)) + <> ":" + <> Text.pack (show (ref ^. #offset)) + ) + Nothing -> Left (DedupePolicyUnsatisfied policy) + CustomDedupeKey k -> + if Text.null k + then Left (DedupePolicyUnsatisfied policy) + else Right k diff --git a/src/Keiro/Outbox.hs b/src/Keiro/Outbox.hs --- a/src/Keiro/Outbox.hs +++ b/src/Keiro/Outbox.hs @@ -1,37 +1,36 @@ -{- | Durable integration-event outbox. - -The outbox decouples "this service has decided to publish an integration -event" from "this service has actually published it". Two surfaces use -it: - -* The canonical 'IntegrationProducer' helper maps durable private events - to public 'Keiro.Integration.Event.IntegrationEvent' values and enqueues - one outbox row per mapped event. It mints @messageId@ as a prefixed - UUIDv7 (TypeID) so the id is time-ordered, human-readable, and stable - across publish retries. -* 'enqueueOutboxTx' is the inline escape hatch for sagas and process - managers that need to emit an integration event without an intermediate - private domain event. It runs inside the caller's - 'Hasql.Transaction.Transaction'. - -The 'publishClaimedOutbox' worker is transport-neutral. It claims rows -with @FOR UPDATE SKIP LOCKED@ plus the configured 'OrderingPolicy', -hands claimed batches to a caller-supplied publish function, and marks rows -sent, retryable, or dead. The Kafka adapter lives in -'Keiro.Outbox.Kafka'. - -Run 'outboxMaintenancePass' on a separate, slower schedule to reclaim rows -left in @publishing@ by crashed workers and to sample the backlog gauge. - -The per-key and per-source ordering policies sort by @created_at@, which -PostgreSQL fills at transaction start. The canonical 'IntegrationProducer' -subscription serializes same-key enqueues, so its ordering is stable. Callers -using the inline 'enqueueIntegrationEventTx' escape hatch concurrently for the -same key must serialize those enqueues themselves or accept best-effort order: -two transactions can commit in the opposite order of their @created_at@ values. --} -module Keiro.Outbox ( - -- * Re-exports +-- | Durable integration-event outbox. +-- +-- The outbox decouples "this service has decided to publish an integration +-- event" from "this service has actually published it". Two surfaces use +-- it: +-- +-- * The canonical 'IntegrationProducer' helper maps durable private events +-- to public 'Keiro.Integration.Event.IntegrationEvent' values and enqueues +-- one outbox row per mapped event. It mints @messageId@ as a prefixed +-- UUIDv7 (TypeID) so the id is time-ordered, human-readable, and stable +-- across publish retries. +-- * 'enqueueOutboxTx' is the inline escape hatch for sagas and process +-- managers that need to emit an integration event without an intermediate +-- private domain event. It runs inside the caller's +-- 'Hasql.Transaction.Transaction'. +-- +-- The 'publishClaimedOutbox' worker is transport-neutral. It claims rows +-- with @FOR UPDATE SKIP LOCKED@ plus the configured 'OrderingPolicy', +-- hands claimed batches to a caller-supplied publish function, and marks rows +-- sent, retryable, or dead. The Kafka adapter lives in +-- 'Keiro.Outbox.Kafka'. +-- +-- Run 'outboxMaintenancePass' on a separate, slower schedule to reclaim rows +-- left in @publishing@ by crashed workers and to sample the backlog gauge. +-- +-- The per-key and per-source ordering policies sort by @created_at@, which +-- PostgreSQL fills at transaction start. The canonical 'IntegrationProducer' +-- subscription serializes same-key enqueues, so its ordering is stable. Callers +-- using the inline 'enqueueIntegrationEventTx' escape hatch concurrently for the +-- same key must serialize those enqueues themselves or accept best-effort order: +-- two transactions can commit in the opposite order of their @created_at@ values. +module Keiro.Outbox + ( -- * Re-exports module Keiro.Outbox.Types, -- * Storage primitives (transport-neutral) @@ -62,7 +61,7 @@ publishClaimedOutbox, outboxMaintenancePass, sampleOutboxBacklog, -) + ) where import Data.ByteString (ByteString) @@ -72,25 +71,25 @@ import Data.UUID.V7 qualified as V7 import Effectful (Eff, IOE, (:>)) import Effectful.Exception (displayException, trySync) -import Keiro.Integration.Event ( - IntegrationContentType, +import Keiro.Integration.Event + ( IntegrationContentType, IntegrationEvent (..), SchemaReference, TraceContext, - ) + ) import Keiro.Outbox.Kafka (outboxRowToKafkaRecord) import Keiro.Outbox.Schema import Keiro.Outbox.Types import Keiro.Prelude -import Keiro.Telemetry ( - KeiroMetrics, +import Keiro.Telemetry + ( KeiroMetrics, recordOutboxBacklog, recordOutboxDeadlettered, recordOutboxPublished, recordOutboxReclaimed, recordOutboxRetried, withProducerSpan, - ) + ) import Kiroku.Store.Effect (Store) import Kiroku.Store.Transaction (runTransaction) import Kiroku.Store.Types (EventId, GlobalPosition, RecordedEvent) @@ -106,161 +105,156 @@ freshOutboxId :: (IOE :> es) => Eff es OutboxId freshOutboxId = fmap OutboxId (liftIO V7.genUUID) -{- | Enqueue an 'IntegrationEvent' from a saga or process manager that is -already running inside a 'runCommandWithSqlEvents' transaction. The -caller supplies a stable 'OutboxId' so retried command attempts coalesce -on the @(source, message_id)@ unique constraint. - -Ordering caveat: under 'PerKeyHeadOfLine' and 'PerSourceStream', the publisher -orders rows by @created_at@, which PostgreSQL sets to transaction-start time. -If two concurrent transactions enqueue the same key/source and commit in the -opposite order, a publisher can observe that order. Serialize same-key enqueues -when strict order matters. --} +-- | Enqueue an 'IntegrationEvent' from a saga or process manager that is +-- already running inside a 'runCommandWithSqlEvents' transaction. The +-- caller supplies a stable 'OutboxId' so retried command attempts coalesce +-- on the @(source, message_id)@ unique constraint. +-- +-- Ordering caveat: under 'PerKeyHeadOfLine' and 'PerSourceStream', the publisher +-- orders rows by @created_at@, which PostgreSQL sets to transaction-start time. +-- If two concurrent transactions enqueue the same key/source and commit in the +-- opposite order, a publisher can observe that order. Serialize same-key enqueues +-- when strict order matters. enqueueIntegrationEventTx :: - OutboxId -> - IntegrationEvent -> - Tx.Transaction () + OutboxId -> + IntegrationEvent -> + Tx.Transaction () enqueueIntegrationEventTx outboxId event = - enqueueOutboxTx (OutboxMessage{outboxId, event}) + enqueueOutboxTx (OutboxMessage {outboxId, event}) -- --------------------------------------------------------------------------- -- Producer-subscription helper -- --------------------------------------------------------------------------- -{- | Configuration for the canonical producer subscription. - -A service running 'IntegrationProducer' reads its private event stream, -decodes each event with a 'Keiro.Codec.Codec', calls 'mapEvent', and for -each 'Just' result writes one 'keiro_outbox' row. The helper mints -@messageId@ on each insert so the id is stable across publish retries. - -* 'name' — subscription name used to checkpoint the producer's cursor - in the @subscriptions@ table. -* 'source' — value written into @keiro_outbox.source@; identifies the - producing bounded context. -* 'messageIdPrefix' — TypeID prefix used when minting @messageId@. - Must be 1-63 lowercase Latin letters (e.g. @\"msg\"@, @\"order\"@). - Prefer constructing producers with 'mkIntegrationProducer'; an invalid - prefix passed directly to 'IntegrationProducer' raises when the first - message id is minted. -* 'mapEvent' — pure mapper from a private 'RecordedEvent' and its - decoded payload to an 'IntegrationEventDraft'. Returning 'Nothing' - skips the event without enqueuing a row. --} +-- | Configuration for the canonical producer subscription. +-- +-- A service running 'IntegrationProducer' reads its private event stream, +-- decodes each event with a 'Keiro.Codec.Codec', calls 'mapEvent', and for +-- each 'Just' result writes one 'keiro_outbox' row. The helper mints +-- @messageId@ on each insert so the id is stable across publish retries. +-- +-- * 'name' — subscription name used to checkpoint the producer's cursor +-- in the @subscriptions@ table. +-- * 'source' — value written into @keiro_outbox.source@; identifies the +-- producing bounded context. +-- * 'messageIdPrefix' — TypeID prefix used when minting @messageId@. +-- Must be 1-63 lowercase Latin letters (e.g. @\"msg\"@, @\"order\"@). +-- Prefer constructing producers with 'mkIntegrationProducer'; an invalid +-- prefix passed directly to 'IntegrationProducer' raises when the first +-- message id is minted. +-- * 'mapEvent' — pure mapper from a private 'RecordedEvent' and its +-- decoded payload to an 'IntegrationEventDraft'. Returning 'Nothing' +-- skips the event without enqueuing a row. data IntegrationProducer e = IntegrationProducer - { name :: !Text - , source :: !Text - , messageIdPrefix :: !Text - , mapEvent :: !(RecordedEvent -> e -> Maybe IntegrationEventDraft) - } - deriving stock (Generic) + { name :: !Text, + source :: !Text, + messageIdPrefix :: !Text, + mapEvent :: !(RecordedEvent -> e -> Maybe IntegrationEventDraft) + } + deriving stock (Generic) data IntegrationProducerConfigError - = InvalidMessageIdPrefix !Text !Text - deriving stock (Generic, Eq, Show) + = InvalidMessageIdPrefix !Text !Text + deriving stock (Generic, Eq, Show) -- | Validate an integration producer before starting its subscription. mkIntegrationProducer :: IntegrationProducer e -> Either IntegrationProducerConfigError (IntegrationProducer e) mkIntegrationProducer producer = - case TypeID.checkPrefix (producer ^. #messageIdPrefix) of - Nothing -> Right producer - Just err -> - Left - ( InvalidMessageIdPrefix - (producer ^. #messageIdPrefix) - (Text.pack (show err)) - ) - -{- | Everything in 'IntegrationEvent' except 'messageId' and 'source' — -those are filled in by 'mintIntegrationEvent' from the producer -configuration and the freshly minted TypeID. + case TypeID.checkPrefix (producer ^. #messageIdPrefix) of + Nothing -> Right producer + Just err -> + Left + ( InvalidMessageIdPrefix + (producer ^. #messageIdPrefix) + (Text.pack (show err)) + ) -@sourceEventId@ and @sourceGlobalPosition@ default to the values on the -underlying 'RecordedEvent' (see 'mintIntegrationEvent'); a mapper that -needs to override them can replace the draft fields directly. --} +-- | Everything in 'IntegrationEvent' except 'messageId' and 'source' — +-- those are filled in by 'mintIntegrationEvent' from the producer +-- configuration and the freshly minted TypeID. +-- +-- @sourceEventId@ and @sourceGlobalPosition@ default to the values on the +-- underlying 'RecordedEvent' (see 'mintIntegrationEvent'); a mapper that +-- needs to override them can replace the draft fields directly. data IntegrationEventDraft = IntegrationEventDraft - { destination :: !Text - , key :: !(Maybe Text) - , eventType :: !Text - , schemaVersion :: !Int - , contentType :: !IntegrationContentType - , schemaReference :: !(Maybe SchemaReference) - , sourceEventId :: !(Maybe EventId) - , sourceGlobalPosition :: !(Maybe GlobalPosition) - , payloadBytes :: !ByteString - , occurredAt :: !UTCTime - , causationId :: !(Maybe EventId) - , correlationId :: !(Maybe EventId) - , traceContext :: !(Maybe TraceContext) - , attributes :: !(Maybe Value) - } - deriving stock (Generic, Eq, Show) + { destination :: !Text, + key :: !(Maybe Text), + eventType :: !Text, + schemaVersion :: !Int, + contentType :: !IntegrationContentType, + schemaReference :: !(Maybe SchemaReference), + sourceEventId :: !(Maybe EventId), + sourceGlobalPosition :: !(Maybe GlobalPosition), + payloadBytes :: !ByteString, + occurredAt :: !UTCTime, + causationId :: !(Maybe EventId), + correlationId :: !(Maybe EventId), + traceContext :: !(Maybe TraceContext), + attributes :: !(Maybe Value) + } + deriving stock (Generic, Eq, Show) -{- | Mint a fresh @messageId@ (TypeID with the producer's prefix) and build -the full 'IntegrationEvent' from the draft. Lives in 'IO' because TypeID -generation reads the global UUIDv7 sequence counter. --} +-- | Mint a fresh @messageId@ (TypeID with the producer's prefix) and build +-- the full 'IntegrationEvent' from the draft. Lives in 'IO' because TypeID +-- generation reads the global UUIDv7 sequence counter. mintIntegrationEvent :: - (IOE :> es) => - IntegrationProducer e -> - IntegrationEventDraft -> - Eff es IntegrationEvent + (IOE :> es) => + IntegrationProducer e -> + IntegrationEventDraft -> + Eff es IntegrationEvent mintIntegrationEvent producer draft = do - typeId <- liftIO (TypeID.genTypeID (producer ^. #messageIdPrefix)) - pure (draftToEvent (producer ^. #source) (TypeID.toText typeId) draft) + typeId <- liftIO (TypeID.genTypeID (producer ^. #messageIdPrefix)) + pure (draftToEvent (producer ^. #source) (TypeID.toText typeId) draft) -- | Build an 'IntegrationEvent' from a source, a minted message id, and a draft. draftToEvent :: Text -> Text -> IntegrationEventDraft -> IntegrationEvent draftToEvent source minted draft = - IntegrationEvent - { messageId = minted - , source - , destination = draft ^. #destination - , key = draft ^. #key - , eventType = draft ^. #eventType - , schemaVersion = draft ^. #schemaVersion - , contentType = draft ^. #contentType - , schemaReference = draft ^. #schemaReference - , sourceEventId = draft ^. #sourceEventId - , sourceGlobalPosition = draft ^. #sourceGlobalPosition - , payloadBytes = draft ^. #payloadBytes - , occurredAt = draft ^. #occurredAt - , causationId = draft ^. #causationId - , correlationId = draft ^. #correlationId - , traceContext = draft ^. #traceContext - , attributes = draft ^. #attributes - } - -{- | Enqueue one drafted producer event inside an existing transaction. - -This is the primitive a subscription worker calls per event. It mints a -fresh @messageId@ (TypeID), constructs the full envelope, and inserts -the row. The caller supplies the 'OutboxId' so retries from a known -subscription cursor coalesce on @(source, message_id)@. - -The TypeID is minted before the insert; if the transaction rolls back -the message id is discarded (no observable effect) and the next attempt -mints a different id. Idempotency at the row level relies on a stable -'OutboxId', not the minted message id. + IntegrationEvent + { messageId = minted, + source, + destination = draft ^. #destination, + key = draft ^. #key, + eventType = draft ^. #eventType, + schemaVersion = draft ^. #schemaVersion, + contentType = draft ^. #contentType, + schemaReference = draft ^. #schemaReference, + sourceEventId = draft ^. #sourceEventId, + sourceGlobalPosition = draft ^. #sourceGlobalPosition, + payloadBytes = draft ^. #payloadBytes, + occurredAt = draft ^. #occurredAt, + causationId = draft ^. #causationId, + correlationId = draft ^. #correlationId, + traceContext = draft ^. #traceContext, + attributes = draft ^. #attributes + } -Ordering caveat: @created_at@ records transaction-start time. Under -'PerKeyHeadOfLine' or 'PerSourceStream', concurrent transactions for the same -key/source can commit in the opposite order and are therefore best-effort -unless the caller serializes them. The canonical producer subscription does -serialize same-key enqueues. --} +-- | Enqueue one drafted producer event inside an existing transaction. +-- +-- This is the primitive a subscription worker calls per event. It mints a +-- fresh @messageId@ (TypeID), constructs the full envelope, and inserts +-- the row. The caller supplies the 'OutboxId' so retries from a known +-- subscription cursor coalesce on @(source, message_id)@. +-- +-- The TypeID is minted before the insert; if the transaction rolls back +-- the message id is discarded (no observable effect) and the next attempt +-- mints a different id. Idempotency at the row level relies on a stable +-- 'OutboxId', not the minted message id. +-- +-- Ordering caveat: @created_at@ records transaction-start time. Under +-- 'PerKeyHeadOfLine' or 'PerSourceStream', concurrent transactions for the same +-- key/source can commit in the opposite order and are therefore best-effort +-- unless the caller serializes them. The canonical producer subscription does +-- serialize same-key enqueues. enqueueProducerEventTx :: - forall e es. - (IOE :> es) => - IntegrationProducer e -> - OutboxId -> - IntegrationEventDraft -> - Eff es (Tx.Transaction ()) + forall e es. + (IOE :> es) => + IntegrationProducer e -> + OutboxId -> + IntegrationEventDraft -> + Eff es (Tx.Transaction ()) enqueueProducerEventTx producer outboxId draft = do - event <- mintIntegrationEvent producer draft - pure (enqueueOutboxTx (OutboxMessage{outboxId, event})) + event <- mintIntegrationEvent producer draft + pure (enqueueOutboxTx (OutboxMessage {outboxId, event})) -- --------------------------------------------------------------------------- -- Publisher worker @@ -268,133 +262,132 @@ -- | Result of one publish attempt as reported by the transport-specific publisher. data PublishOutcome - = -- | Kafka acknowledged the publish. - PublishSucceeded - | -- | Publish failed; will be retried after the configured backoff. - PublishFailed !Text - deriving stock (Generic, Eq, Show) - -{- | Drain claimed outbox rows by handing the claimed batch to @publish@ and -reflecting the outcomes back into row statuses. - -Claims rows in batches of @batchSize@ under the active 'OrderingPolicy', -calls @publish@ with the claimed rows in claim order, and marks every row -sent or — using 'markOutboxFailedTx' — failed/dead. The publish result must -contain one outcome per input row; a missing outcome is treated as -@PublishFailed "publisher returned no outcome"@. If the publisher throws, -every row in that call is treated as failed with the exception text. - -For ordered policies, if a row fails then later rows in the same ordered group -are skipped and returned to @failed@ without consuming an attempt; these -skipped rows count as 'OutboxPublishSummary.retried'. A real Kafka transport -must not successfully deliver a later same-key record after reporting an -earlier same-key failure from the same call. On 'StopTheLine', the worker calls -@publish@ with singleton batches and halts after the first failed row, recording -the offending 'OutboxId' in 'haltedOn'. - -Returns when one of: - -* No rows are claimable. -* The active policy is 'StopTheLine' and a publish failed. + = -- | Kafka acknowledged the publish. + PublishSucceeded + | -- | Publish failed; will be retried after the configured backoff. + PublishFailed !Text + deriving stock (Generic, Eq, Show) -The worker does not loop indefinitely; the application is expected to -schedule it repeatedly (e.g. once per process-compose tick). --} +-- | Drain claimed outbox rows by handing the claimed batch to @publish@ and +-- reflecting the outcomes back into row statuses. +-- +-- Claims rows in batches of @batchSize@ under the active 'OrderingPolicy', +-- calls @publish@ with the claimed rows in claim order, and marks every row +-- sent or — using 'markOutboxFailedTx' — failed/dead. The publish result must +-- contain one outcome per input row; a missing outcome is treated as +-- @PublishFailed "publisher returned no outcome"@. If the publisher throws, +-- every row in that call is treated as failed with the exception text. +-- +-- For ordered policies, if a row fails then later rows in the same ordered group +-- are skipped and returned to @failed@ without consuming an attempt; these +-- skipped rows count as 'OutboxPublishSummary.retried'. A real Kafka transport +-- must not successfully deliver a later same-key record after reporting an +-- earlier same-key failure from the same call. On 'StopTheLine', the worker calls +-- @publish@ with singleton batches and halts after the first failed row, recording +-- the offending 'OutboxId' in 'haltedOn'. +-- +-- Returns when one of: +-- +-- * No rows are claimable. +-- * The active policy is 'StopTheLine' and a publish failed. +-- +-- The worker does not loop indefinitely; the application is expected to +-- schedule it repeatedly (e.g. once per process-compose tick). publishClaimedOutbox :: - forall es. - (IOE :> es, Store :> es) => - ([OutboxRow] -> Eff es [(OutboxId, PublishOutcome)]) -> - OutboxPublishOptions -> - Maybe KeiroMetrics -> - Eff es OutboxPublishSummary + forall es. + (IOE :> es, Store :> es) => + ([OutboxRow] -> Eff es [(OutboxId, PublishOutcome)]) -> + OutboxPublishOptions -> + Maybe KeiroMetrics -> + Eff es OutboxPublishSummary publishClaimedOutbox publish options mMetrics = do - now <- liftIO getCurrentTime - rows <- claimOutboxBatch (options ^. #orderingPolicy) (options ^. #batchSize) now - summary <- publishBatch rows - -- Counters from the aggregated pass summary (each a no-op under 'Nothing'; - -- a zero delta is harmless). - recordOutboxPublished mMetrics (fromIntegral (summary ^. #published)) - recordOutboxRetried mMetrics (fromIntegral (summary ^. #retried)) - recordOutboxDeadlettered mMetrics (fromIntegral (summary ^. #dead)) - pure summary + now <- liftIO getCurrentTime + rows <- claimOutboxBatch (options ^. #orderingPolicy) (options ^. #batchSize) now + summary <- publishBatch rows + -- Counters from the aggregated pass summary (each a no-op under 'Nothing'; + -- a zero delta is harmless). + recordOutboxPublished mMetrics (fromIntegral (summary ^. #published)) + recordOutboxRetried mMetrics (fromIntegral (summary ^. #retried)) + recordOutboxDeadlettered mMetrics (fromIntegral (summary ^. #dead)) + pure summary where publishBatch :: [OutboxRow] -> Eff es OutboxPublishSummary publishBatch [] = - pure OutboxPublishSummary{claimed = 0, published = 0, retried = 0, dead = 0, haltedOn = Nothing} + pure OutboxPublishSummary {claimed = 0, published = 0, retried = 0, dead = 0, haltedOn = Nothing} publishBatch batch = - case options ^. #orderingPolicy of - StopTheLine -> publishStopTheLine batch batch [] Nothing - policy -> do - outcomes <- publishRows batch - markProcessedOutcomes policy batch outcomes Nothing + case options ^. #orderingPolicy of + StopTheLine -> publishStopTheLine batch batch [] Nothing + policy -> do + outcomes <- publishRows batch + markProcessedOutcomes policy batch outcomes Nothing publishStopTheLine :: - [OutboxRow] -> - [OutboxRow] -> - [(OutboxId, PublishOutcome)] -> - Maybe OutboxId -> - Eff es OutboxPublishSummary + [OutboxRow] -> + [OutboxRow] -> + [(OutboxId, PublishOutcome)] -> + Maybe OutboxId -> + Eff es OutboxPublishSummary publishStopTheLine original [] outcomes halted = - markProcessedOutcomes StopTheLine original (Map.fromList outcomes) halted + markProcessedOutcomes StopTheLine original (Map.fromList outcomes) halted publishStopTheLine original (row : rest) outcomes _ = do - result <- publishRows [row] - let outcome = outcomeFor result row - outcomes' = outcomes <> [(row ^. #outboxId, outcome)] - case outcome of - PublishSucceeded -> publishStopTheLine original rest outcomes' Nothing - PublishFailed _ -> markProcessedOutcomes StopTheLine original (Map.fromList outcomes') (Just (row ^. #outboxId)) + result <- publishRows [row] + let outcome = outcomeFor result row + outcomes' = outcomes <> [(row ^. #outboxId, outcome)] + case outcome of + PublishSucceeded -> publishStopTheLine original rest outcomes' Nothing + PublishFailed _ -> markProcessedOutcomes StopTheLine original (Map.fromList outcomes') (Just (row ^. #outboxId)) publishRows :: [OutboxRow] -> Eff es (Map.Map OutboxId PublishOutcome) publishRows [] = pure Map.empty publishRows batch@(firstRow : _) = - Map.fromList - <$> withBatchSpan - batch - firstRow - ( do - attempted <- trySync (publish batch) - let normalized = - case attempted of - Left err -> - let errMsg = Text.pack (displayException err) - in [(row ^. #outboxId, PublishFailed errMsg) | row <- batch] - Right reported -> - normalizeOutcomes batch reported - pure normalized - ) + Map.fromList + <$> withBatchSpan + batch + firstRow + ( do + attempted <- trySync (publish batch) + let normalized = + case attempted of + Left err -> + let errMsg = Text.pack (displayException err) + in [(row ^. #outboxId, PublishFailed errMsg) | row <- batch] + Right reported -> + normalizeOutcomes batch reported + pure normalized + ) withBatchSpan :: - [OutboxRow] -> - OutboxRow -> - Eff es [(OutboxId, PublishOutcome)] -> - Eff es [(OutboxId, PublishOutcome)] + [OutboxRow] -> + OutboxRow -> + Eff es [(OutboxId, PublishOutcome)] -> + Eff es [(OutboxId, PublishOutcome)] withBatchSpan batch firstRow action = - withProducerSpan - (options ^. #tracer) - (firstRow ^. #event) - (outboxRowToKafkaRecord firstRow) - $ \mSpan -> do - for_ mSpan $ \sp -> - addAttribute sp (unkey keiro_outbox_batch_size) (fromIntegral (length batch) :: Int64) - outcomes <- action - case (mSpan, firstFailure outcomes) of - (Just sp, Just errMsg) -> do - addAttribute sp (unkey error_type) ("publish_failed" :: Text) - setStatus sp (Error errMsg) - _ -> pure () - pure outcomes + withProducerSpan + (options ^. #tracer) + (firstRow ^. #event) + (outboxRowToKafkaRecord firstRow) + $ \mSpan -> do + for_ mSpan $ \sp -> + addAttribute sp (unkey keiro_outbox_batch_size) (fromIntegral (length batch) :: Int64) + outcomes <- action + case (mSpan, firstFailure outcomes) of + (Just sp, Just errMsg) -> do + addAttribute sp (unkey error_type) ("publish_failed" :: Text) + setStatus sp (Error errMsg) + _ -> pure () + pure outcomes normalizeOutcomes :: [OutboxRow] -> [(OutboxId, PublishOutcome)] -> [(OutboxId, PublishOutcome)] normalizeOutcomes batch reported = - let reportedMap = Map.fromList reported - in [ (row ^. #outboxId, outcomeFor reportedMap row) - | row <- batch - ] + let reportedMap = Map.fromList reported + in [ (row ^. #outboxId, outcomeFor reportedMap row) + | row <- batch + ] outcomeFor :: Map.Map OutboxId PublishOutcome -> OutboxRow -> PublishOutcome outcomeFor outcomes row = - fromMaybe (PublishFailed "publisher returned no outcome") $ - Map.lookup (row ^. #outboxId) outcomes + fromMaybe (PublishFailed "publisher returned no outcome") $ + Map.lookup (row ^. #outboxId) outcomes firstFailure :: [(OutboxId, PublishOutcome)] -> Maybe Text firstFailure [] = Nothing @@ -402,152 +395,151 @@ firstFailure ((_, PublishFailed errMsg) : _) = Just errMsg markProcessedOutcomes :: - OrderingPolicy -> - [OutboxRow] -> - Map.Map OutboxId PublishOutcome -> - Maybe OutboxId -> - Eff es OutboxPublishSummary + OrderingPolicy -> + [OutboxRow] -> + Map.Map OutboxId PublishOutcome -> + Maybe OutboxId -> + Eff es OutboxPublishSummary markProcessedOutcomes policy batch outcomes halted = do - now <- liftIO getCurrentTime - let marks = foldMap (groupMarks outcomes) (outcomeGroups policy batch) - sentIds = marks ^. #sentIds - failedRows = marks ^. #failedRows - skippedRows = marks ^. #skippedRows - failedStatuses <- - if null failedRows && null skippedRows - then pure [] - else runTransaction $ do - statuses <- traverse (markFailed now) failedRows - traverse_ (markSkipped now) skippedRows - pure statuses - _ <- markOutboxSentBatch sentIds now - let deadCount = length [() | OutboxDead <- failedStatuses] - retriedFailures = length failedStatuses - deadCount - pure - OutboxPublishSummary - { claimed = length batch - , published = length sentIds - , retried = retriedFailures + length skippedRows - , dead = deadCount - , haltedOn = halted - } + now <- liftIO getCurrentTime + let marks = foldMap (groupMarks outcomes) (outcomeGroups policy batch) + sentIds = marks ^. #sentIds + failedRows = marks ^. #failedRows + skippedRows = marks ^. #skippedRows + failedStatuses <- + if null failedRows && null skippedRows + then pure [] + else runTransaction $ do + statuses <- traverse (markFailed now) failedRows + traverse_ (markSkipped now) skippedRows + pure statuses + _ <- markOutboxSentBatch sentIds now + let deadCount = length [() | OutboxDead <- failedStatuses] + retriedFailures = length failedStatuses - deadCount + pure + OutboxPublishSummary + { claimed = length batch, + published = length sentIds, + retried = retriedFailures + length skippedRows, + dead = deadCount, + haltedOn = halted + } markFailed :: UTCTime -> (OutboxRow, Text) -> Tx.Transaction OutboxStatus markFailed now (row, errMsg) = - markOutboxFailedTx - (row ^. #outboxId) - errMsg - (options ^. #maxAttempts) - (nextDelay (options ^. #backoff) (row ^. #attemptCount)) - now + markOutboxFailedTx + (row ^. #outboxId) + errMsg + (options ^. #maxAttempts) + (nextDelay (options ^. #backoff) (row ^. #attemptCount)) + now markSkipped :: UTCTime -> OutboxRow -> Tx.Transaction () markSkipped now row = - markOutboxSkippedTx - (row ^. #outboxId) - "skipped: earlier record for the same key failed" - now - -{- | Reclaim crashed publisher rows and record the outbox backlog gauge. + markOutboxSkippedTx + (row ^. #outboxId) + "skipped: earlier record for the same key failed" + now -Schedule this pass independently from 'publishClaimedOutbox', typically on a -slower timer. It is the only library worker path that reclaims rows stranded in -@publishing@. --} +-- | Reclaim crashed publisher rows and record the outbox backlog gauge. +-- +-- Schedule this pass independently from 'publishClaimedOutbox', typically on a +-- slower timer. It is the only library worker path that reclaims rows stranded in +-- @publishing@. outboxMaintenancePass :: - (IOE :> es, Store :> es) => - OutboxMaintenanceOptions -> - Maybe KeiroMetrics -> - Eff es OutboxMaintenanceSummary + (IOE :> es, Store :> es) => + OutboxMaintenanceOptions -> + Maybe KeiroMetrics -> + Eff es OutboxMaintenanceSummary outboxMaintenancePass options mMetrics = do - now <- liftIO getCurrentTime - (requeued, deadLettered) <- - requeueStuckOutbox - (options ^. #maxAttempts) - (options ^. #publishingTimeout) - now - recordOutboxReclaimed mMetrics (fromIntegral requeued) - recordOutboxDeadlettered mMetrics (fromIntegral deadLettered) - backlog <- countOutboxBacklog - recordOutboxBacklog mMetrics (fromIntegral backlog) - pure OutboxMaintenanceSummary{requeued, deadLettered, backlog} + now <- liftIO getCurrentTime + (requeued, deadLettered) <- + requeueStuckOutbox + (options ^. #maxAttempts) + (options ^. #publishingTimeout) + now + recordOutboxReclaimed mMetrics (fromIntegral requeued) + recordOutboxDeadlettered mMetrics (fromIntegral deadLettered) + backlog <- countOutboxBacklog + recordOutboxBacklog mMetrics (fromIntegral backlog) + pure OutboxMaintenanceSummary {requeued, deadLettered, backlog} -- | Count publishable rows and record the outbox backlog gauge when metrics are enabled. sampleOutboxBacklog :: (IOE :> es, Store :> es) => Maybe KeiroMetrics -> Eff es () sampleOutboxBacklog Nothing = pure () sampleOutboxBacklog (Just metrics) = do - backlog <- countOutboxBacklog - recordOutboxBacklog (Just metrics) (fromIntegral backlog) + backlog <- countOutboxBacklog + recordOutboxBacklog (Just metrics) (fromIntegral backlog) data OutcomeMarks = OutcomeMarks - { sentIds :: ![OutboxId] - , failedRows :: ![(OutboxRow, Text)] - , skippedRows :: ![OutboxRow] - } - deriving stock (Generic) + { sentIds :: ![OutboxId], + failedRows :: ![(OutboxRow, Text)], + skippedRows :: ![OutboxRow] + } + deriving stock (Generic) instance Semigroup OutcomeMarks where - left <> right = - OutcomeMarks - { sentIds = (left ^. #sentIds) <> (right ^. #sentIds) - , failedRows = (left ^. #failedRows) <> (right ^. #failedRows) - , skippedRows = (left ^. #skippedRows) <> (right ^. #skippedRows) - } + left <> right = + OutcomeMarks + { sentIds = (left ^. #sentIds) <> (right ^. #sentIds), + failedRows = (left ^. #failedRows) <> (right ^. #failedRows), + skippedRows = (left ^. #skippedRows) <> (right ^. #skippedRows) + } instance Monoid OutcomeMarks where - mempty = OutcomeMarks{sentIds = [], failedRows = [], skippedRows = []} + mempty = OutcomeMarks {sentIds = [], failedRows = [], skippedRows = []} groupMarks :: Map.Map OutboxId PublishOutcome -> [OutboxRow] -> OutcomeMarks groupMarks outcomes = go [] where - go sent [] = mempty{sentIds = sent} + go sent [] = mempty {sentIds = sent} go sent (row : rest) = - case fromMaybe (PublishFailed "publisher returned no outcome") (Map.lookup (row ^. #outboxId) outcomes) of - PublishSucceeded -> go (sent <> [row ^. #outboxId]) rest - PublishFailed errMsg -> - OutcomeMarks - { sentIds = sent - , failedRows = [(row, errMsg)] - , skippedRows = rest - } + case fromMaybe (PublishFailed "publisher returned no outcome") (Map.lookup (row ^. #outboxId) outcomes) of + PublishSucceeded -> go (sent <> [row ^. #outboxId]) rest + PublishFailed errMsg -> + OutcomeMarks + { sentIds = sent, + failedRows = [(row, errMsg)], + skippedRows = rest + } data OutcomeGroupKey - = BatchGroup - | SourceGroup !Text - | RowGroup !OutboxId - | KeyGroup !Text !Text - deriving stock (Generic, Eq) + = BatchGroup + | SourceGroup !Text + | RowGroup !OutboxId + | KeyGroup !Text !Text + deriving stock (Generic, Eq) data OutcomeGroup = OutcomeGroup - { groupKey :: !OutcomeGroupKey - , groupRows :: ![OutboxRow] - } - deriving stock (Generic) + { groupKey :: !OutcomeGroupKey, + groupRows :: ![OutboxRow] + } + deriving stock (Generic) outcomeGroups :: OrderingPolicy -> [OutboxRow] -> [[OutboxRow]] outcomeGroups policy = - fmap (^. #groupRows) . foldl' addGroup [] + fmap (^. #groupRows) . foldl' addGroup [] where addGroup groups row = - appendGroup (keyFor row) row groups + appendGroup (keyFor row) row groups keyFor row = - case policy of - -- A claimed batch can hold runs from several independent sources; - -- a failure in one source's run must not skip another source's rows. - PerSourceStream -> SourceGroup (row ^. #event . #source) - -- Deliberately one group: any failure halts the worker, and the - -- entire remaining batch is skipped without consuming attempts. - StopTheLine -> BatchGroup - BestEffort -> RowGroup (row ^. #outboxId) - _ -> - case row ^. #event . #key of - Nothing -> RowGroup (row ^. #outboxId) - Just key -> KeyGroup (row ^. #event . #source) key + case policy of + -- A claimed batch can hold runs from several independent sources; + -- a failure in one source's run must not skip another source's rows. + PerSourceStream -> SourceGroup (row ^. #event . #source) + -- Deliberately one group: any failure halts the worker, and the + -- entire remaining batch is skipped without consuming attempts. + StopTheLine -> BatchGroup + BestEffort -> RowGroup (row ^. #outboxId) + _ -> + case row ^. #event . #key of + Nothing -> RowGroup (row ^. #outboxId) + Just key -> KeyGroup (row ^. #event . #source) key appendGroup :: OutcomeGroupKey -> OutboxRow -> [OutcomeGroup] -> [OutcomeGroup] -appendGroup key row [] = [OutcomeGroup{groupKey = key, groupRows = [row]}] +appendGroup key row [] = [OutcomeGroup {groupKey = key, groupRows = [row]}] appendGroup key row (group : rest) - | group ^. #groupKey == key = - (group & #groupRows %~ (<> [row])) : rest - | otherwise = - group : appendGroup key row rest + | group ^. #groupKey == key = + (group & #groupRows %~ (<> [row])) : rest + | otherwise = + group : appendGroup key row rest diff --git a/src/Keiro/Outbox/Kafka.hs b/src/Keiro/Outbox/Kafka.hs --- a/src/Keiro/Outbox/Kafka.hs +++ b/src/Keiro/Outbox/Kafka.hs @@ -1,27 +1,26 @@ -{- | Transport-neutral Kafka representation for outbox rows. - -This module owns the conversion from 'Keiro.Outbox.Types.OutboxRow' to a -neutral 'KafkaProducerRecord' value. It deliberately does not import -@hw-kafka-client@ or @kafka-effectful@: keiro itself remains free of -librdkafka system-library requirements. The integration test package -(EP-22) bridges 'KafkaProducerRecord' to -@Kafka.Producer.Types.ProducerRecord@ from @hw-kafka-client@ inside its -own dependency scope. - -A 'KafkaProducerRecord' carries everything the broker layer needs: -topic, optional partition key, the raw payload bytes from the EP-19 -envelope, and the canonical header set. Building the record is pure; -publishing is the caller's responsibility. - -The outbox worker opens one producer span around each claimed publish batch. -Adapters that need per-record broker visibility should add their own spans -around the actual Kafka produce calls. --} -module Keiro.Outbox.Kafka ( - KafkaProducerRecord (..), +-- | Transport-neutral Kafka representation for outbox rows. +-- +-- This module owns the conversion from 'Keiro.Outbox.Types.OutboxRow' to a +-- neutral 'KafkaProducerRecord' value. It deliberately does not import +-- @hw-kafka-client@ or @kafka-effectful@: keiro itself remains free of +-- librdkafka system-library requirements. The integration test package +-- (EP-22) bridges 'KafkaProducerRecord' to +-- @Kafka.Producer.Types.ProducerRecord@ from @hw-kafka-client@ inside its +-- own dependency scope. +-- +-- A 'KafkaProducerRecord' carries everything the broker layer needs: +-- topic, optional partition key, the raw payload bytes from the EP-19 +-- envelope, and the canonical header set. Building the record is pure; +-- publishing is the caller's responsibility. +-- +-- The outbox worker opens one producer span around each claimed publish batch. +-- Adapters that need per-record broker visibility should add their own spans +-- around the actual Kafka produce calls. +module Keiro.Outbox.Kafka + ( KafkaProducerRecord (..), outboxRowToKafkaRecord, integrationEventToKafkaRecord, -) + ) where import Data.ByteString (ByteString) @@ -30,30 +29,29 @@ import Keiro.Outbox.Types (OutboxRow (..)) import Keiro.Prelude -{- | A neutral Kafka producer record. - -Fields: - -* 'topic' — Kafka topic, taken from 'IntegrationEvent.destination'. -* 'key' — partition key bytes (UTF-8 encoded). 'Nothing' means - Kafka round-robins the record across partitions and skips per-key - ordering. -* 'payload' — exactly the bytes from - 'Keiro.Integration.Event.integrationPayload'. -* 'headers' — UTF-8 encoded view of - 'Keiro.Integration.Event.integrationHeaders'. - -The byte encoding for keys and headers is UTF-8 by convention; Kafka -treats both as opaque bytes, so a future binary-key transport can drop -the encoding by populating 'key' directly. --} +-- | A neutral Kafka producer record. +-- +-- Fields: +-- +-- * 'topic' — Kafka topic, taken from 'IntegrationEvent.destination'. +-- * 'key' — partition key bytes (UTF-8 encoded). 'Nothing' means +-- Kafka round-robins the record across partitions and skips per-key +-- ordering. +-- * 'payload' — exactly the bytes from +-- 'Keiro.Integration.Event.integrationPayload'. +-- * 'headers' — UTF-8 encoded view of +-- 'Keiro.Integration.Event.integrationHeaders'. +-- +-- The byte encoding for keys and headers is UTF-8 by convention; Kafka +-- treats both as opaque bytes, so a future binary-key transport can drop +-- the encoding by populating 'key' directly. data KafkaProducerRecord = KafkaProducerRecord - { topic :: !Text - , key :: !(Maybe ByteString) - , payload :: !ByteString - , headers :: ![(ByteString, ByteString)] - } - deriving stock (Generic, Eq, Show) + { topic :: !Text, + key :: !(Maybe ByteString), + payload :: !ByteString, + headers :: ![(ByteString, ByteString)] + } + deriving stock (Generic, Eq, Show) -- | Build a 'KafkaProducerRecord' from a published outbox row. outboxRowToKafkaRecord :: OutboxRow -> KafkaProducerRecord @@ -62,9 +60,9 @@ -- | Build a 'KafkaProducerRecord' directly from an 'IntegrationEvent'. integrationEventToKafkaRecord :: IntegrationEvent -> KafkaProducerRecord integrationEventToKafkaRecord event = - KafkaProducerRecord - { topic = event ^. #destination - , key = fmap TE.encodeUtf8 (event ^. #key) - , payload = integrationPayload event - , headers = [(TE.encodeUtf8 n, TE.encodeUtf8 v) | (n, v) <- integrationHeaders event] - } + KafkaProducerRecord + { topic = event ^. #destination, + key = fmap TE.encodeUtf8 (event ^. #key), + payload = integrationPayload event, + headers = [(TE.encodeUtf8 n, TE.encodeUtf8 v) | (n, v) <- integrationHeaders event] + } diff --git a/src/Keiro/Outbox/Schema.hs b/src/Keiro/Outbox/Schema.hs --- a/src/Keiro/Outbox/Schema.hs +++ b/src/Keiro/Outbox/Schema.hs @@ -1,811 +1,799 @@ {-# LANGUAGE ApplicativeDo #-} -{- | Hasql-level storage for the durable integration-event outbox. - -This module owns the SQL surface that publishers call into. Higher-level -helpers ('Keiro.Outbox') and transport adapters -('Keiro.Outbox.Kafka') consume these primitives. --} -module Keiro.Outbox.Schema ( - enqueueOutboxTx, - claimOutboxBatch, - requeueStuckOutbox, - markOutboxSent, - markOutboxSentBatch, - markOutboxFailedTx, - markOutboxSkippedTx, - lookupOutbox, - listOutbox, - countOutboxBacklog, - garbageCollectSent, -) -where - -import Contravariant.Extras (contrazip2, contrazip3, contrazip5) -import Data.ByteString (ByteString) -import Data.Functor.Contravariant ((>$<)) -import Data.Time.Clock (NominalDiffTime, addUTCTime) -import Data.UUID (UUID) -import Effectful (Eff, (:>)) -import Hasql.Decoders qualified as D -import Hasql.Encoders qualified as E -import Hasql.Statement (Statement, preparable) -import Keiro.Integration.Event ( - IntegrationEvent (..), - SchemaReference (..), - TraceContext (..), - contentTypeText, - parseContentType, - ) -import Keiro.Outbox.Types -import Keiro.Prelude -import Kiroku.Store.Effect (Store) -import Kiroku.Store.Transaction (runTransaction) -import Kiroku.Store.Types (EventId (..), GlobalPosition (..)) -import "hasql-transaction" Hasql.Transaction qualified as Tx - -{- | Enqueue one integration event inside an existing transaction. - -The @(source, message_id)@ unique constraint catches duplicate retries -from a saga/process-manager. Callers that mint a fresh @messageId@ per -attempt should also mint a fresh @outboxId@; callers that want -idempotent retries should reuse both. - -The row's @created_at@ value is the PostgreSQL transaction-start time. The -per-key and per-source publisher policies therefore provide only best-effort -ordering when concurrent transactions enqueue the same key/source and commit -in the opposite order. Serialize those transactions when strict order matters; -the canonical producer subscription already does so. --} -enqueueOutboxTx :: OutboxMessage -> Tx.Transaction () -enqueueOutboxTx message = - Tx.statement (toEncodedRow message) enqueueOutboxStmt - --- | Read a single outbox row by id. Used by tests and inspection tooling. -lookupOutbox :: (Store :> es) => OutboxId -> Eff es (Maybe OutboxRow) -lookupOutbox outboxId = - runTransaction $ - Tx.statement (unOutboxId outboxId) lookupOutboxStmt - -{- | List outbox rows for a source, ordered by @created_at@. Used by tests; -not intended for application traffic. --} -listOutbox :: (Store :> es) => Text -> Eff es [OutboxRow] -listOutbox source = - runTransaction $ - Tx.statement source listOutboxStmt - -{- | Count outbox rows awaiting publish (backlog gauge source). - -Backlog = rows in a claimable, non-terminal state. Mirrors the claim -query's @status IN ('pending','failed')@ predicate so the gauge measures -exactly the rows a publisher still has to drain (rows held mid-pass in -@publishing@, and the terminal @sent@/@dead@ rows, are excluded). --} -countOutboxBacklog :: (Store :> es) => Eff es Int -countOutboxBacklog = - runTransaction (Tx.statement () countBacklogStmt) - -{- | Delete @sent@ rows whose @published_at@ is older than @keepFor@ before -@now@. - -Returns the number of rows deleted. @dead@ rows are never deleted: they are -operator action items proving an event was not published. The retention window -only bounds how long successful publish history remains queryable; consumer -dedupe lives in the inbox, not here. --} -garbageCollectSent :: - (Store :> es) => - NominalDiffTime -> - UTCTime -> - Eff es Int -garbageCollectSent keepFor now = do - let cutoff = addUTCTime (negate keepFor) now - result <- - runTransaction $ - Tx.statement cutoff gcSentStmt - pure (fromIntegral result) - -{- | Claim up to @limit@ rows ready for publish. - -Rows in @pending@ or @failed@ status whose @next_attempt_at@ has passed -become candidates. The selection is filtered by 'OrderingPolicy': - -* 'PerKeyHeadOfLine' — a row is claimed only if every earlier - non-terminal row with the same @(source, message_key)@ is also claimed - by the same statement. Rows with @message_key IS NULL@ bypass the - per-key check. -* 'PerSourceStream' — a row is claimed only if every earlier - non-terminal row in the same @source@ is also claimed by the same - statement, regardless of key. -* 'StopTheLine' — same as 'PerKeyHeadOfLine' at claim time; the worker - halts on the first failure (decided at the worker level). -* 'BestEffort' — no head-of-line predicate. - -The returned list preserves @(created_at, outbox_id)@ order. Per-key and -per-source subsequences are therefore gapless ordered runs. The @LIMIT@ -applies to the locked candidate set before the post-filter; under -concurrent claimers or a limit cut through the middle of a run, a pass -can return fewer than @limit@ rows even when more rows are ready. - -Claimed rows are transitioned to @publishing@ and have their -@attempt_count@ incremented atomically. --} -claimOutboxBatch :: - (Store :> es) => - OrderingPolicy -> - Int -> - UTCTime -> - Eff es [OutboxRow] -claimOutboxBatch policy limit now = - runTransaction $ - Tx.statement (fromIntegral limit, now) (claimStmt policy) - -{- | Reclaim rows stranded in @publishing@ longer than @olderThan@. - -Rows whose claim already consumed the attempt budget are dead-lettered; the -rest return to @failed@ so the regular claim query can retry them. Returns -@(requeued, deadLettered)@. --} -requeueStuckOutbox :: - (Store :> es) => - Int -> - NominalDiffTime -> - UTCTime -> - Eff es (Int, Int) -requeueStuckOutbox maxAttempts olderThan now = - runTransaction $ do - let cutoff = addUTCTime (negate olderThan) now - dead <- Tx.statement (cutoff, fromIntegral maxAttempts, now) deadLetterStuckStmt - requeued <- Tx.statement (cutoff, fromIntegral maxAttempts, now) requeueStuckStmt - pure (fromIntegral requeued, fromIntegral dead) - -{- | Mark a row as successfully published. Sets @published_at@ and clears -@last_error@. Returns 'False' if the row left @publishing@ before the mark, -for example because a stale-row sweeper or operator changed it while the -transport publish was in flight. The publish may still have happened; callers -must treat this as at-least-once delivery. --} -markOutboxSent :: (Store :> es) => OutboxId -> UTCTime -> Eff es Bool -markOutboxSent outboxId now = - runTransaction $ - Tx.statement (unOutboxId outboxId, now) markSentStmt - -{- | Mark many rows as successfully published in one statement. - -Only rows still in @publishing@ transition. Returns how many rows changed; -callers treat a shortfall as benign because delivery is already at-least-once. --} -markOutboxSentBatch :: (Store :> es) => [OutboxId] -> UTCTime -> Eff es Int -markOutboxSentBatch [] _ = pure 0 -markOutboxSentBatch outboxIds now = - fromIntegral - <$> runTransaction - ( Tx.statement - (fmap unOutboxId outboxIds, now) - markSentBatchStmt - ) - -{- | Mark a row as failed and decide whether it is retryable or dead. - -Reads the current @attempt_count@; if it is greater than or equal to -@maxAttempts@, transitions to 'OutboxDead'. Otherwise transitions to -'OutboxFailed' and sets @next_attempt_at = now + delay@. Returns the -resulting status so the worker can update its summary counters. - -Runs inside the caller's transaction to keep "read attempt count → write -status" atomic with respect to other workers. - -Only rows still in @publishing@ are updated (matching 'markSentBatchStmt' -and 'markSkippedStmt'): if the row outlived 'publishingTimeout' and -'outboxMaintenancePass' already requeued it — possibly handing it to -another worker — a late failure mark from the original worker must not -flip the re-claimed row mid-publish. --} -markOutboxFailedTx :: - OutboxId -> - Text -> - Int -> - NominalDiffTime -> - UTCTime -> - Tx.Transaction OutboxStatus -markOutboxFailedTx outboxId errMsg maxAttempts delay now = do - currentAttempt <- Tx.statement (unOutboxId outboxId) readAttemptCountStmt - let attempt = fromMaybe 0 currentAttempt - shouldDie = attempt >= maxAttempts - nextStatus = if shouldDie then OutboxDead else OutboxFailed - nextAttempt = addUTCTime delay now - Tx.statement - (unOutboxId outboxId, statusText nextStatus, errMsg, nextAttempt, now) - markFailedStmt - pure nextStatus - -{- | Return a claimed row to @failed@ without consuming an attempt. - -Used for rows skipped because an earlier row in the same ordered group failed -inside the same publish batch. --} -markOutboxSkippedTx :: OutboxId -> Text -> UTCTime -> Tx.Transaction () -markOutboxSkippedTx outboxId errMsg now = - Tx.statement (unOutboxId outboxId, errMsg, now) markSkippedStmt - --- --------------------------------------------------------------------------- --- Encoder support --- --------------------------------------------------------------------------- - -{- | Flattened row used as the encoder input. Field order is locked to -the INSERT statement; the encoder threads each field through a separate -'E.Params' fragment joined by 'mconcat'. --} -data EncodedRow = EncodedRow - { outboxId :: !UUID - , messageId :: !Text - , source :: !Text - , destination :: !Text - , messageKey :: !(Maybe Text) - , eventType :: !Text - , schemaVersion :: !Int64 - , contentType :: !Text - , schemaRegistry :: !(Maybe Text) - , schemaSubject :: !(Maybe Text) - , schemaVersionRef :: !(Maybe Int64) - , schemaId :: !(Maybe Int64) - , schemaFingerprint :: !(Maybe Text) - , sourceEventId :: !(Maybe UUID) - , sourceGlobalPosition :: !(Maybe Int64) - , causationId :: !(Maybe UUID) - , correlationId :: !(Maybe UUID) - , traceparent :: !(Maybe Text) - , tracestate :: !(Maybe Text) - , payloadBytes :: !ByteString - , attributes :: !(Maybe Value) - , occurredAt :: !UTCTime - } - deriving stock (Generic) - -toEncodedRow :: OutboxMessage -> EncodedRow -toEncodedRow message = - let event = message ^. #event - mref = event ^. #schemaReference - mtrace = event ^. #traceContext - in EncodedRow - { outboxId = unOutboxId (message ^. #outboxId) - , messageId = event ^. #messageId - , source = event ^. #source - , destination = event ^. #destination - , messageKey = event ^. #key - , eventType = event ^. #eventType - , schemaVersion = fromIntegral (event ^. #schemaVersion) - , contentType = contentTypeText (event ^. #contentType) - , schemaRegistry = mref >>= (^. #registry) - , schemaSubject = mref >>= (^. #subject) - , schemaVersionRef = fmap fromIntegral (mref >>= (^. #version)) - , schemaId = mref >>= (^. #schemaId) - , schemaFingerprint = mref >>= (^. #fingerprint) - , sourceEventId = fmap unEventId (event ^. #sourceEventId) - , sourceGlobalPosition = fmap unGlobalPosition (event ^. #sourceGlobalPosition) - , causationId = fmap unEventId (event ^. #causationId) - , correlationId = fmap unEventId (event ^. #correlationId) - , traceparent = fmap (^. #traceparent) mtrace - , tracestate = mtrace >>= (^. #tracestate) - , payloadBytes = event ^. #payloadBytes - , attributes = event ^. #attributes - , occurredAt = event ^. #occurredAt - } - -unEventId :: EventId -> UUID -unEventId (EventId u) = u - -unGlobalPosition :: GlobalPosition -> Int64 -unGlobalPosition (GlobalPosition i) = i - -encodedRowEncoder :: E.Params EncodedRow -encodedRowEncoder = - mconcat - [ view #outboxId >$< E.param (E.nonNullable E.uuid) - , view #messageId >$< E.param (E.nonNullable E.text) - , view #source >$< E.param (E.nonNullable E.text) - , view #destination >$< E.param (E.nonNullable E.text) - , view #messageKey >$< E.param (E.nullable E.text) - , view #eventType >$< E.param (E.nonNullable E.text) - , view #schemaVersion >$< E.param (E.nonNullable E.int8) - , view #contentType >$< E.param (E.nonNullable E.text) - , view #schemaRegistry >$< E.param (E.nullable E.text) - , view #schemaSubject >$< E.param (E.nullable E.text) - , view #schemaVersionRef >$< E.param (E.nullable E.int8) - , view #schemaId >$< E.param (E.nullable E.int8) - , view #schemaFingerprint >$< E.param (E.nullable E.text) - , view #sourceEventId >$< E.param (E.nullable E.uuid) - , view #sourceGlobalPosition >$< E.param (E.nullable E.int8) - , view #causationId >$< E.param (E.nullable E.uuid) - , view #correlationId >$< E.param (E.nullable E.uuid) - , view #traceparent >$< E.param (E.nullable E.text) - , view #tracestate >$< E.param (E.nullable E.text) - , view #payloadBytes >$< E.param (E.nonNullable E.bytea) - , view #attributes >$< E.param (E.nullable E.jsonb) - , view #occurredAt >$< E.param (E.nonNullable E.timestamptz) - ] - --- --------------------------------------------------------------------------- --- Statements --- --------------------------------------------------------------------------- - -enqueueOutboxStmt :: Statement EncodedRow () -enqueueOutboxStmt = - preparable - """ - INSERT INTO keiro.keiro_outbox - ( outbox_id - , message_id - , source - , destination - , message_key - , event_type - , schema_version - , content_type - , schema_registry - , schema_subject - , schema_version_ref - , schema_id - , schema_fingerprint - , source_event_id - , source_global_position - , causation_id - , correlation_id - , traceparent - , tracestate - , payload_bytes - , attributes - , occurred_at - ) - VALUES - ($1, $2, $3, $4, $5, $6, $7, $8, $9, $10, $11, $12, $13, $14, $15, $16, $17, $18, $19, $20, $21, $22) - ON CONFLICT (source, message_id) DO NOTHING - """ - encodedRowEncoder - D.noResult - -claimStmt :: OrderingPolicy -> Statement (Int64, UTCTime) [OutboxRow] -claimStmt policy = - preparable - (claimSql (policyPredicates policy)) - ( contrazip2 - (E.param (E.nonNullable E.int8)) - (E.param (E.nonNullable E.timestamptz)) - ) - (D.rowList claimResultDecoder) - -data PolicyPredicates = PolicyPredicates - { preFilter :: !Text - , postFilter :: !Text - } - deriving stock (Generic) - -policyPredicates :: OrderingPolicy -> PolicyPredicates -policyPredicates = \case - PerKeyHeadOfLine -> perKeyPredicates - PerSourceStream -> perSourcePredicates - StopTheLine -> perKeyPredicates - BestEffort -> PolicyPredicates{preFilter = "TRUE", postFilter = "TRUE"} - -perKeyPredicates :: PolicyPredicates -perKeyPredicates = - PolicyPredicates - { preFilter = - """ - ( r.message_key IS NULL OR NOT EXISTS ( - SELECT 1 FROM keiro.keiro_outbox earlier - WHERE earlier.source = r.source - AND earlier.message_key = r.message_key - AND (earlier.created_at, earlier.outbox_id) < (r.created_at, r.outbox_id) - AND earlier.status NOT IN ('sent', 'dead') - AND NOT (earlier.status IN ('pending', 'failed') AND earlier.next_attempt_at <= $2) ) ) - """ - , postFilter = - """ - ( c.message_key IS NULL OR NOT EXISTS ( - SELECT 1 FROM keiro.keiro_outbox earlier - WHERE earlier.source = c.source - AND earlier.message_key = c.message_key - AND (earlier.created_at, earlier.outbox_id) < (c.created_at, c.outbox_id) - AND earlier.status NOT IN ('sent', 'dead') - AND NOT EXISTS ( - SELECT 1 FROM candidate c2 - WHERE c2.outbox_id = earlier.outbox_id ) ) ) - """ - } - -perSourcePredicates :: PolicyPredicates -perSourcePredicates = - PolicyPredicates - { preFilter = - """ - NOT EXISTS ( - SELECT 1 FROM keiro.keiro_outbox earlier - WHERE earlier.source = r.source - AND (earlier.created_at, earlier.outbox_id) < (r.created_at, r.outbox_id) - AND earlier.status NOT IN ('sent', 'dead') - AND NOT (earlier.status IN ('pending', 'failed') AND earlier.next_attempt_at <= $2) ) - """ - , postFilter = - """ - NOT EXISTS ( - SELECT 1 FROM keiro.keiro_outbox earlier - WHERE earlier.source = c.source - AND (earlier.created_at, earlier.outbox_id) < (c.created_at, c.outbox_id) - AND earlier.status NOT IN ('sent', 'dead') - AND NOT EXISTS ( - SELECT 1 FROM candidate c2 - WHERE c2.outbox_id = earlier.outbox_id ) ) - """ - } - -claimSql :: PolicyPredicates -> Text -claimSql PolicyPredicates{preFilter, postFilter} = - """ - WITH candidate AS ( - SELECT r.outbox_id, r.source, r.message_key, r.created_at - FROM keiro.keiro_outbox r - WHERE r.status IN ('pending', 'failed') - AND r.next_attempt_at <= $2 - AND ( - """ - <> preFilter - <> """ - - ) - ORDER BY r.created_at, r.outbox_id - LIMIT $1 - FOR UPDATE SKIP LOCKED - ), - ready AS ( - SELECT c.outbox_id, c.created_at AS claim_created_at - FROM candidate c - WHERE ( - """ - <> postFilter - <> """ - - ) - ), - updated AS ( - UPDATE keiro.keiro_outbox kt - SET status = 'publishing', attempt_count = kt.attempt_count + 1, updated_at = $2 - FROM ready - WHERE kt.outbox_id = ready.outbox_id - RETURNING ready.claim_created_at, - - """ - <> rowColumns - <> """ - - ) - SELECT - - """ - <> unqualifiedRowColumns - <> """ - - FROM updated - ORDER BY claim_created_at, outbox_id - """ - -rowColumns :: Text -rowColumns = - """ - kt.outbox_id, kt.message_id, kt.source, kt.destination, kt.message_key, - kt.event_type, kt.schema_version, kt.content_type, kt.schema_registry, - kt.schema_subject, kt.schema_version_ref, kt.schema_id, kt.schema_fingerprint, - kt.source_event_id, kt.source_global_position, kt.causation_id, - kt.correlation_id, kt.traceparent, kt.tracestate, kt.payload_bytes, - kt.attributes, kt.occurred_at, kt.status, kt.attempt_count, - kt.next_attempt_at, kt.last_error, kt.published_at, kt.created_at, - kt.updated_at - """ - -unqualifiedRowColumns :: Text -unqualifiedRowColumns = - """ - outbox_id, message_id, source, destination, message_key, - event_type, schema_version, content_type, schema_registry, - schema_subject, schema_version_ref, schema_id, schema_fingerprint, - source_event_id, source_global_position, causation_id, - correlation_id, traceparent, tracestate, payload_bytes, - attributes, occurred_at, status, attempt_count, - next_attempt_at, last_error, published_at, created_at, - updated_at - """ - -claimResultDecoder :: D.Row OutboxRow -claimResultDecoder = outboxRowDecoder - -countBacklogStmt :: Statement () Int -countBacklogStmt = - preparable - "SELECT COUNT(*)::bigint FROM keiro.keiro_outbox WHERE status IN ('pending', 'failed')" - E.noParams - (fmap fromIntegral (D.singleRow (D.column (D.nonNullable D.int8)))) - -gcSentStmt :: Statement UTCTime Int64 -gcSentStmt = - preparable - """ - WITH deleted AS ( - DELETE FROM keiro.keiro_outbox - WHERE status = 'sent' AND published_at < $1 - RETURNING 1 - ) - SELECT COALESCE(COUNT(*), 0)::bigint FROM deleted - """ - (E.param (E.nonNullable E.timestamptz)) - (D.singleRow (D.column (D.nonNullable D.int8))) - -readAttemptCountStmt :: Statement UUID (Maybe Int) -readAttemptCountStmt = - preparable - "SELECT attempt_count FROM keiro.keiro_outbox WHERE outbox_id = $1" - (E.param (E.nonNullable E.uuid)) - (D.rowMaybe (fromIntegral <$> D.column (D.nonNullable D.int8))) - -deadLetterStuckStmt :: Statement (UTCTime, Int64, UTCTime) Int64 -deadLetterStuckStmt = - preparable - """ - UPDATE keiro.keiro_outbox - SET status = 'dead', - last_error = COALESCE(last_error, 'reclaimed: publisher crashed mid-publish'), - updated_at = $3 - WHERE status = 'publishing' - AND updated_at <= $1 - AND attempt_count >= $2 - """ - ( contrazip3 - (E.param (E.nonNullable E.timestamptz)) - (E.param (E.nonNullable E.int8)) - (E.param (E.nonNullable E.timestamptz)) - ) - D.rowsAffected - -requeueStuckStmt :: Statement (UTCTime, Int64, UTCTime) Int64 -requeueStuckStmt = - preparable - """ - UPDATE keiro.keiro_outbox - SET status = 'failed', - updated_at = $3 - WHERE status = 'publishing' - AND updated_at <= $1 - AND attempt_count < $2 - """ - ( contrazip3 - (E.param (E.nonNullable E.timestamptz)) - (E.param (E.nonNullable E.int8)) - (E.param (E.nonNullable E.timestamptz)) - ) - D.rowsAffected - -markSentStmt :: Statement (UUID, UTCTime) Bool -markSentStmt = - preparable - """ - UPDATE keiro.keiro_outbox - SET status = 'sent', - published_at = $2, - last_error = NULL, - updated_at = $2 - WHERE outbox_id = $1 - AND status = 'publishing' - """ - ( contrazip2 - (E.param (E.nonNullable E.uuid)) - (E.param (E.nonNullable E.timestamptz)) - ) - ((> 0) <$> D.rowsAffected) - -markSentBatchStmt :: Statement ([UUID], UTCTime) Int64 -markSentBatchStmt = - preparable - """ - UPDATE keiro.keiro_outbox - SET status = 'sent', - published_at = $2, - last_error = NULL, - updated_at = $2 - WHERE outbox_id = ANY($1) - AND status = 'publishing' - """ - ( contrazip2 - (E.param (E.nonNullable (E.foldableArray (E.nonNullable E.uuid)))) - (E.param (E.nonNullable E.timestamptz)) - ) - D.rowsAffected - -markFailedStmt :: Statement (UUID, Text, Text, UTCTime, UTCTime) () -markFailedStmt = - preparable - """ - UPDATE keiro.keiro_outbox - SET status = $2, - last_error = $3, - next_attempt_at = $4, - updated_at = $5 - WHERE outbox_id = $1 - AND status = 'publishing' - """ - ( contrazip5 - (E.param (E.nonNullable E.uuid)) - (E.param (E.nonNullable E.text)) - (E.param (E.nonNullable E.text)) - (E.param (E.nonNullable E.timestamptz)) - (E.param (E.nonNullable E.timestamptz)) - ) - D.noResult - -markSkippedStmt :: Statement (UUID, Text, UTCTime) () -markSkippedStmt = - preparable - """ - UPDATE keiro.keiro_outbox - SET status = 'failed', - attempt_count = GREATEST(attempt_count - 1, 0), - last_error = $2, - next_attempt_at = $3, - updated_at = $3 - WHERE outbox_id = $1 - AND status = 'publishing' - """ - ( contrazip3 - (E.param (E.nonNullable E.uuid)) - (E.param (E.nonNullable E.text)) - (E.param (E.nonNullable E.timestamptz)) - ) - D.noResult - -lookupOutboxStmt :: Statement UUID (Maybe OutboxRow) -lookupOutboxStmt = - preparable - (selectAllSql <> " WHERE outbox_id = $1") - (E.param (E.nonNullable E.uuid)) - (D.rowMaybe outboxRowDecoder) - -listOutboxStmt :: Statement Text [OutboxRow] -listOutboxStmt = - preparable - (selectAllSql <> " WHERE source = $1 ORDER BY created_at, outbox_id") - (E.param (E.nonNullable E.text)) - (D.rowList outboxRowDecoder) - -selectAllSql :: Text -selectAllSql = - """ - SELECT outbox_id, message_id, source, destination, message_key, event_type, - schema_version, content_type, schema_registry, schema_subject, - schema_version_ref, schema_id, schema_fingerprint, source_event_id, - source_global_position, causation_id, correlation_id, traceparent, - tracestate, payload_bytes, attributes, occurred_at, status, - attempt_count, next_attempt_at, last_error, published_at, created_at, - updated_at - FROM keiro.keiro_outbox - """ - -outboxRowDecoder :: D.Row OutboxRow -outboxRowDecoder = fmap assembleRow rawRowDecoder - -data RawRow = RawRow - { outboxId :: !OutboxId - , messageId :: !Text - , source :: !Text - , destination :: !Text - , key :: !(Maybe Text) - , eventType :: !Text - , schemaVersion :: !Int - , contentType :: !Text - , schemaRegistry :: !(Maybe Text) - , schemaSubject :: !(Maybe Text) - , schemaVersionRef :: !(Maybe Int) - , schemaId :: !(Maybe Int64) - , schemaFingerprint :: !(Maybe Text) - , sourceEventId :: !(Maybe EventId) - , sourceGlobalPosition :: !(Maybe GlobalPosition) - , causationId :: !(Maybe EventId) - , correlationId :: !(Maybe EventId) - , traceparent :: !(Maybe Text) - , tracestate :: !(Maybe Text) - , payloadBytes :: !ByteString - , attributes :: !(Maybe Value) - , occurredAt :: !UTCTime - , status :: !OutboxStatus - , attemptCount :: !Int - , nextAttemptAt :: !UTCTime - , lastError :: !(Maybe Text) - , publishedAt :: !(Maybe UTCTime) - , createdAt :: !UTCTime - , updatedAt :: !UTCTime - } - deriving stock (Generic) - -rawRowDecoder :: D.Row RawRow -rawRowDecoder = - RawRow - <$> (OutboxId <$> D.column (D.nonNullable D.uuid)) - <*> D.column (D.nonNullable D.text) - <*> D.column (D.nonNullable D.text) - <*> D.column (D.nonNullable D.text) - <*> D.column (D.nullable D.text) - <*> D.column (D.nonNullable D.text) - <*> (fromIntegral <$> D.column (D.nonNullable D.int8)) - <*> D.column (D.nonNullable D.text) - <*> D.column (D.nullable D.text) - <*> D.column (D.nullable D.text) - <*> (fmap fromIntegral <$> D.column (D.nullable D.int8)) - <*> D.column (D.nullable D.int8) - <*> D.column (D.nullable D.text) - <*> (fmap EventId <$> D.column (D.nullable D.uuid)) - <*> (fmap GlobalPosition <$> D.column (D.nullable D.int8)) - <*> (fmap EventId <$> D.column (D.nullable D.uuid)) - <*> (fmap EventId <$> D.column (D.nullable D.uuid)) - <*> D.column (D.nullable D.text) - <*> D.column (D.nullable D.text) - <*> D.column (D.nonNullable D.bytea) - <*> D.column (D.nullable D.jsonb) - <*> D.column (D.nonNullable D.timestamptz) - <*> D.column (D.nonNullable (D.refine parseStatus D.text)) - <*> (fromIntegral <$> D.column (D.nonNullable D.int8)) - <*> D.column (D.nonNullable D.timestamptz) - <*> D.column (D.nullable D.text) - <*> D.column (D.nullable D.timestamptz) - <*> D.column (D.nonNullable D.timestamptz) - <*> D.column (D.nonNullable D.timestamptz) - -assembleRow :: RawRow -> OutboxRow -assembleRow raw = - let traceContext = case raw ^. #traceparent of - Nothing -> Nothing - Just tp -> Just (TraceContext tp (raw ^. #tracestate)) - schemaReference = - case ( raw ^. #schemaRegistry - , raw ^. #schemaSubject - , raw ^. #schemaVersionRef - , raw ^. #schemaId - , raw ^. #schemaFingerprint - ) of - (Nothing, Nothing, Nothing, Nothing, Nothing) -> Nothing - _ -> - Just - ( SchemaReference - (raw ^. #schemaRegistry) - (raw ^. #schemaSubject) - (raw ^. #schemaVersionRef) - (raw ^. #schemaId) - (raw ^. #schemaFingerprint) - ) - event = - IntegrationEvent - { messageId = raw ^. #messageId - , source = raw ^. #source - , destination = raw ^. #destination - , key = raw ^. #key - , eventType = raw ^. #eventType - , schemaVersion = raw ^. #schemaVersion - , contentType = parseContentType (raw ^. #contentType) - , schemaReference - , sourceEventId = raw ^. #sourceEventId - , sourceGlobalPosition = raw ^. #sourceGlobalPosition - , payloadBytes = raw ^. #payloadBytes - , occurredAt = raw ^. #occurredAt - , causationId = raw ^. #causationId - , correlationId = raw ^. #correlationId - , traceContext - , attributes = raw ^. #attributes - } - in OutboxRow - { outboxId = raw ^. #outboxId - , event - , status = raw ^. #status - , attemptCount = raw ^. #attemptCount - , nextAttemptAt = raw ^. #nextAttemptAt - , lastError = raw ^. #lastError - , publishedAt = raw ^. #publishedAt - , createdAt = raw ^. #createdAt - , updatedAt = raw ^. #updatedAt - } +-- | Hasql-level storage for the durable integration-event outbox. +-- +-- This module owns the SQL surface that publishers call into. Higher-level +-- helpers ('Keiro.Outbox') and transport adapters +-- ('Keiro.Outbox.Kafka') consume these primitives. +module Keiro.Outbox.Schema + ( enqueueOutboxTx, + claimOutboxBatch, + requeueStuckOutbox, + markOutboxSent, + markOutboxSentBatch, + markOutboxFailedTx, + markOutboxSkippedTx, + lookupOutbox, + listOutbox, + countOutboxBacklog, + garbageCollectSent, + ) +where + +import Contravariant.Extras (contrazip2, contrazip3, contrazip5) +import Data.ByteString (ByteString) +import Data.Functor.Contravariant ((>$<)) +import Data.Time.Clock (NominalDiffTime, addUTCTime) +import Data.UUID (UUID) +import Effectful (Eff, (:>)) +import Hasql.Decoders qualified as D +import Hasql.Encoders qualified as E +import Hasql.Statement (Statement, preparable) +import Keiro.Integration.Event + ( IntegrationEvent (..), + SchemaReference (..), + TraceContext (..), + contentTypeText, + parseContentType, + ) +import Keiro.Outbox.Types +import Keiro.Prelude +import Kiroku.Store.Effect (Store) +import Kiroku.Store.Transaction (runTransaction) +import Kiroku.Store.Types (EventId (..), GlobalPosition (..)) +import "hasql-transaction" Hasql.Transaction qualified as Tx + +-- | Enqueue one integration event inside an existing transaction. +-- +-- The @(source, message_id)@ unique constraint catches duplicate retries +-- from a saga/process-manager. Callers that mint a fresh @messageId@ per +-- attempt should also mint a fresh @outboxId@; callers that want +-- idempotent retries should reuse both. +-- +-- The row's @created_at@ value is the PostgreSQL transaction-start time. The +-- per-key and per-source publisher policies therefore provide only best-effort +-- ordering when concurrent transactions enqueue the same key/source and commit +-- in the opposite order. Serialize those transactions when strict order matters; +-- the canonical producer subscription already does so. +enqueueOutboxTx :: OutboxMessage -> Tx.Transaction () +enqueueOutboxTx message = + Tx.statement (toEncodedRow message) enqueueOutboxStmt + +-- | Read a single outbox row by id. Used by tests and inspection tooling. +lookupOutbox :: (Store :> es) => OutboxId -> Eff es (Maybe OutboxRow) +lookupOutbox outboxId = + runTransaction $ + Tx.statement (unOutboxId outboxId) lookupOutboxStmt + +-- | List outbox rows for a source, ordered by @created_at@. Used by tests; +-- not intended for application traffic. +listOutbox :: (Store :> es) => Text -> Eff es [OutboxRow] +listOutbox source = + runTransaction $ + Tx.statement source listOutboxStmt + +-- | Count outbox rows awaiting publish (backlog gauge source). +-- +-- Backlog = rows in a claimable, non-terminal state. Mirrors the claim +-- query's @status IN ('pending','failed')@ predicate so the gauge measures +-- exactly the rows a publisher still has to drain (rows held mid-pass in +-- @publishing@, and the terminal @sent@/@dead@ rows, are excluded). +countOutboxBacklog :: (Store :> es) => Eff es Int +countOutboxBacklog = + runTransaction (Tx.statement () countBacklogStmt) + +-- | Delete @sent@ rows whose @published_at@ is older than @keepFor@ before +-- @now@. +-- +-- Returns the number of rows deleted. @dead@ rows are never deleted: they are +-- operator action items proving an event was not published. The retention window +-- only bounds how long successful publish history remains queryable; consumer +-- dedupe lives in the inbox, not here. +garbageCollectSent :: + (Store :> es) => + NominalDiffTime -> + UTCTime -> + Eff es Int +garbageCollectSent keepFor now = do + let cutoff = addUTCTime (negate keepFor) now + result <- + runTransaction $ + Tx.statement cutoff gcSentStmt + pure (fromIntegral result) + +-- | Claim up to @limit@ rows ready for publish. +-- +-- Rows in @pending@ or @failed@ status whose @next_attempt_at@ has passed +-- become candidates. The selection is filtered by 'OrderingPolicy': +-- +-- * 'PerKeyHeadOfLine' — a row is claimed only if every earlier +-- non-terminal row with the same @(source, message_key)@ is also claimed +-- by the same statement. Rows with @message_key IS NULL@ bypass the +-- per-key check. +-- * 'PerSourceStream' — a row is claimed only if every earlier +-- non-terminal row in the same @source@ is also claimed by the same +-- statement, regardless of key. +-- * 'StopTheLine' — same as 'PerKeyHeadOfLine' at claim time; the worker +-- halts on the first failure (decided at the worker level). +-- * 'BestEffort' — no head-of-line predicate. +-- +-- The returned list preserves @(created_at, outbox_id)@ order. Per-key and +-- per-source subsequences are therefore gapless ordered runs. The @LIMIT@ +-- applies to the locked candidate set before the post-filter; under +-- concurrent claimers or a limit cut through the middle of a run, a pass +-- can return fewer than @limit@ rows even when more rows are ready. +-- +-- Claimed rows are transitioned to @publishing@ and have their +-- @attempt_count@ incremented atomically. +claimOutboxBatch :: + (Store :> es) => + OrderingPolicy -> + Int -> + UTCTime -> + Eff es [OutboxRow] +claimOutboxBatch policy limit now = + runTransaction $ + Tx.statement (fromIntegral limit, now) (claimStmt policy) + +-- | Reclaim rows stranded in @publishing@ longer than @olderThan@. +-- +-- Rows whose claim already consumed the attempt budget are dead-lettered; the +-- rest return to @failed@ so the regular claim query can retry them. Returns +-- @(requeued, deadLettered)@. +requeueStuckOutbox :: + (Store :> es) => + Int -> + NominalDiffTime -> + UTCTime -> + Eff es (Int, Int) +requeueStuckOutbox maxAttempts olderThan now = + runTransaction $ do + let cutoff = addUTCTime (negate olderThan) now + dead <- Tx.statement (cutoff, fromIntegral maxAttempts, now) deadLetterStuckStmt + requeued <- Tx.statement (cutoff, fromIntegral maxAttempts, now) requeueStuckStmt + pure (fromIntegral requeued, fromIntegral dead) + +-- | Mark a row as successfully published. Sets @published_at@ and clears +-- @last_error@. Returns 'False' if the row left @publishing@ before the mark, +-- for example because a stale-row sweeper or operator changed it while the +-- transport publish was in flight. The publish may still have happened; callers +-- must treat this as at-least-once delivery. +markOutboxSent :: (Store :> es) => OutboxId -> UTCTime -> Eff es Bool +markOutboxSent outboxId now = + runTransaction $ + Tx.statement (unOutboxId outboxId, now) markSentStmt + +-- | Mark many rows as successfully published in one statement. +-- +-- Only rows still in @publishing@ transition. Returns how many rows changed; +-- callers treat a shortfall as benign because delivery is already at-least-once. +markOutboxSentBatch :: (Store :> es) => [OutboxId] -> UTCTime -> Eff es Int +markOutboxSentBatch [] _ = pure 0 +markOutboxSentBatch outboxIds now = + fromIntegral + <$> runTransaction + ( Tx.statement + (fmap unOutboxId outboxIds, now) + markSentBatchStmt + ) + +-- | Mark a row as failed and decide whether it is retryable or dead. +-- +-- Reads the current @attempt_count@; if it is greater than or equal to +-- @maxAttempts@, transitions to 'OutboxDead'. Otherwise transitions to +-- 'OutboxFailed' and sets @next_attempt_at = now + delay@. Returns the +-- resulting status so the worker can update its summary counters. +-- +-- Runs inside the caller's transaction to keep "read attempt count → write +-- status" atomic with respect to other workers. +-- +-- Only rows still in @publishing@ are updated (matching 'markSentBatchStmt' +-- and 'markSkippedStmt'): if the row outlived 'publishingTimeout' and +-- 'outboxMaintenancePass' already requeued it — possibly handing it to +-- another worker — a late failure mark from the original worker must not +-- flip the re-claimed row mid-publish. +markOutboxFailedTx :: + OutboxId -> + Text -> + Int -> + NominalDiffTime -> + UTCTime -> + Tx.Transaction OutboxStatus +markOutboxFailedTx outboxId errMsg maxAttempts delay now = do + currentAttempt <- Tx.statement (unOutboxId outboxId) readAttemptCountStmt + let attempt = fromMaybe 0 currentAttempt + shouldDie = attempt >= maxAttempts + nextStatus = if shouldDie then OutboxDead else OutboxFailed + nextAttempt = addUTCTime delay now + Tx.statement + (unOutboxId outboxId, statusText nextStatus, errMsg, nextAttempt, now) + markFailedStmt + pure nextStatus + +-- | Return a claimed row to @failed@ without consuming an attempt. +-- +-- Used for rows skipped because an earlier row in the same ordered group failed +-- inside the same publish batch. +markOutboxSkippedTx :: OutboxId -> Text -> UTCTime -> Tx.Transaction () +markOutboxSkippedTx outboxId errMsg now = + Tx.statement (unOutboxId outboxId, errMsg, now) markSkippedStmt + +-- --------------------------------------------------------------------------- +-- Encoder support +-- --------------------------------------------------------------------------- + +-- | Flattened row used as the encoder input. Field order is locked to +-- the INSERT statement; the encoder threads each field through a separate +-- 'E.Params' fragment joined by 'mconcat'. +data EncodedRow = EncodedRow + { outboxId :: !UUID, + messageId :: !Text, + source :: !Text, + destination :: !Text, + messageKey :: !(Maybe Text), + eventType :: !Text, + schemaVersion :: !Int64, + contentType :: !Text, + schemaRegistry :: !(Maybe Text), + schemaSubject :: !(Maybe Text), + schemaVersionRef :: !(Maybe Int64), + schemaId :: !(Maybe Int64), + schemaFingerprint :: !(Maybe Text), + sourceEventId :: !(Maybe UUID), + sourceGlobalPosition :: !(Maybe Int64), + causationId :: !(Maybe UUID), + correlationId :: !(Maybe UUID), + traceparent :: !(Maybe Text), + tracestate :: !(Maybe Text), + payloadBytes :: !ByteString, + attributes :: !(Maybe Value), + occurredAt :: !UTCTime + } + deriving stock (Generic) + +toEncodedRow :: OutboxMessage -> EncodedRow +toEncodedRow message = + let event = message ^. #event + mref = event ^. #schemaReference + mtrace = event ^. #traceContext + in EncodedRow + { outboxId = unOutboxId (message ^. #outboxId), + messageId = event ^. #messageId, + source = event ^. #source, + destination = event ^. #destination, + messageKey = event ^. #key, + eventType = event ^. #eventType, + schemaVersion = fromIntegral (event ^. #schemaVersion), + contentType = contentTypeText (event ^. #contentType), + schemaRegistry = mref >>= (^. #registry), + schemaSubject = mref >>= (^. #subject), + schemaVersionRef = fmap fromIntegral (mref >>= (^. #version)), + schemaId = mref >>= (^. #schemaId), + schemaFingerprint = mref >>= (^. #fingerprint), + sourceEventId = fmap unEventId (event ^. #sourceEventId), + sourceGlobalPosition = fmap unGlobalPosition (event ^. #sourceGlobalPosition), + causationId = fmap unEventId (event ^. #causationId), + correlationId = fmap unEventId (event ^. #correlationId), + traceparent = fmap (^. #traceparent) mtrace, + tracestate = mtrace >>= (^. #tracestate), + payloadBytes = event ^. #payloadBytes, + attributes = event ^. #attributes, + occurredAt = event ^. #occurredAt + } + +unEventId :: EventId -> UUID +unEventId (EventId u) = u + +unGlobalPosition :: GlobalPosition -> Int64 +unGlobalPosition (GlobalPosition i) = i + +encodedRowEncoder :: E.Params EncodedRow +encodedRowEncoder = + mconcat + [ view #outboxId >$< E.param (E.nonNullable E.uuid), + view #messageId >$< E.param (E.nonNullable E.text), + view #source >$< E.param (E.nonNullable E.text), + view #destination >$< E.param (E.nonNullable E.text), + view #messageKey >$< E.param (E.nullable E.text), + view #eventType >$< E.param (E.nonNullable E.text), + view #schemaVersion >$< E.param (E.nonNullable E.int8), + view #contentType >$< E.param (E.nonNullable E.text), + view #schemaRegistry >$< E.param (E.nullable E.text), + view #schemaSubject >$< E.param (E.nullable E.text), + view #schemaVersionRef >$< E.param (E.nullable E.int8), + view #schemaId >$< E.param (E.nullable E.int8), + view #schemaFingerprint >$< E.param (E.nullable E.text), + view #sourceEventId >$< E.param (E.nullable E.uuid), + view #sourceGlobalPosition >$< E.param (E.nullable E.int8), + view #causationId >$< E.param (E.nullable E.uuid), + view #correlationId >$< E.param (E.nullable E.uuid), + view #traceparent >$< E.param (E.nullable E.text), + view #tracestate >$< E.param (E.nullable E.text), + view #payloadBytes >$< E.param (E.nonNullable E.bytea), + view #attributes >$< E.param (E.nullable E.jsonb), + view #occurredAt >$< E.param (E.nonNullable E.timestamptz) + ] + +-- --------------------------------------------------------------------------- +-- Statements +-- --------------------------------------------------------------------------- + +enqueueOutboxStmt :: Statement EncodedRow () +enqueueOutboxStmt = + preparable + """ + INSERT INTO keiro.keiro_outbox + ( outbox_id + , message_id + , source + , destination + , message_key + , event_type + , schema_version + , content_type + , schema_registry + , schema_subject + , schema_version_ref + , schema_id + , schema_fingerprint + , source_event_id + , source_global_position + , causation_id + , correlation_id + , traceparent + , tracestate + , payload_bytes + , attributes + , occurred_at + ) + VALUES + ($1, $2, $3, $4, $5, $6, $7, $8, $9, $10, $11, $12, $13, $14, $15, $16, $17, $18, $19, $20, $21, $22) + ON CONFLICT (source, message_id) DO NOTHING + """ + encodedRowEncoder + D.noResult + +claimStmt :: OrderingPolicy -> Statement (Int64, UTCTime) [OutboxRow] +claimStmt policy = + preparable + (claimSql (policyPredicates policy)) + ( contrazip2 + (E.param (E.nonNullable E.int8)) + (E.param (E.nonNullable E.timestamptz)) + ) + (D.rowList claimResultDecoder) + +data PolicyPredicates = PolicyPredicates + { preFilter :: !Text, + postFilter :: !Text + } + deriving stock (Generic) + +policyPredicates :: OrderingPolicy -> PolicyPredicates +policyPredicates = \case + PerKeyHeadOfLine -> perKeyPredicates + PerSourceStream -> perSourcePredicates + StopTheLine -> perKeyPredicates + BestEffort -> PolicyPredicates {preFilter = "TRUE", postFilter = "TRUE"} + +perKeyPredicates :: PolicyPredicates +perKeyPredicates = + PolicyPredicates + { preFilter = + """ + ( r.message_key IS NULL OR NOT EXISTS ( + SELECT 1 FROM keiro.keiro_outbox earlier + WHERE earlier.source = r.source + AND earlier.message_key = r.message_key + AND (earlier.created_at, earlier.outbox_id) < (r.created_at, r.outbox_id) + AND earlier.status NOT IN ('sent', 'dead') + AND NOT (earlier.status IN ('pending', 'failed') AND earlier.next_attempt_at <= $2) ) ) + """, + postFilter = + """ + ( c.message_key IS NULL OR NOT EXISTS ( + SELECT 1 FROM keiro.keiro_outbox earlier + WHERE earlier.source = c.source + AND earlier.message_key = c.message_key + AND (earlier.created_at, earlier.outbox_id) < (c.created_at, c.outbox_id) + AND earlier.status NOT IN ('sent', 'dead') + AND NOT EXISTS ( + SELECT 1 FROM candidate c2 + WHERE c2.outbox_id = earlier.outbox_id ) ) ) + """ + } + +perSourcePredicates :: PolicyPredicates +perSourcePredicates = + PolicyPredicates + { preFilter = + """ + NOT EXISTS ( + SELECT 1 FROM keiro.keiro_outbox earlier + WHERE earlier.source = r.source + AND (earlier.created_at, earlier.outbox_id) < (r.created_at, r.outbox_id) + AND earlier.status NOT IN ('sent', 'dead') + AND NOT (earlier.status IN ('pending', 'failed') AND earlier.next_attempt_at <= $2) ) + """, + postFilter = + """ + NOT EXISTS ( + SELECT 1 FROM keiro.keiro_outbox earlier + WHERE earlier.source = c.source + AND (earlier.created_at, earlier.outbox_id) < (c.created_at, c.outbox_id) + AND earlier.status NOT IN ('sent', 'dead') + AND NOT EXISTS ( + SELECT 1 FROM candidate c2 + WHERE c2.outbox_id = earlier.outbox_id ) ) + """ + } + +claimSql :: PolicyPredicates -> Text +claimSql PolicyPredicates {preFilter, postFilter} = + """ + WITH candidate AS ( + SELECT r.outbox_id, r.source, r.message_key, r.created_at + FROM keiro.keiro_outbox r + WHERE r.status IN ('pending', 'failed') + AND r.next_attempt_at <= $2 + AND ( + """ + <> preFilter + <> """ + + ) + ORDER BY r.created_at, r.outbox_id + LIMIT $1 + FOR UPDATE SKIP LOCKED + ), + ready AS ( + SELECT c.outbox_id, c.created_at AS claim_created_at + FROM candidate c + WHERE ( + """ + <> postFilter + <> """ + + ) + ), + updated AS ( + UPDATE keiro.keiro_outbox kt + SET status = 'publishing', attempt_count = kt.attempt_count + 1, updated_at = $2 + FROM ready + WHERE kt.outbox_id = ready.outbox_id + RETURNING ready.claim_created_at, + + """ + <> rowColumns + <> """ + + ) + SELECT + + """ + <> unqualifiedRowColumns + <> """ + + FROM updated + ORDER BY claim_created_at, outbox_id + """ + +rowColumns :: Text +rowColumns = + """ + kt.outbox_id, kt.message_id, kt.source, kt.destination, kt.message_key, + kt.event_type, kt.schema_version, kt.content_type, kt.schema_registry, + kt.schema_subject, kt.schema_version_ref, kt.schema_id, kt.schema_fingerprint, + kt.source_event_id, kt.source_global_position, kt.causation_id, + kt.correlation_id, kt.traceparent, kt.tracestate, kt.payload_bytes, + kt.attributes, kt.occurred_at, kt.status, kt.attempt_count, + kt.next_attempt_at, kt.last_error, kt.published_at, kt.created_at, + kt.updated_at + """ + +unqualifiedRowColumns :: Text +unqualifiedRowColumns = + """ + outbox_id, message_id, source, destination, message_key, + event_type, schema_version, content_type, schema_registry, + schema_subject, schema_version_ref, schema_id, schema_fingerprint, + source_event_id, source_global_position, causation_id, + correlation_id, traceparent, tracestate, payload_bytes, + attributes, occurred_at, status, attempt_count, + next_attempt_at, last_error, published_at, created_at, + updated_at + """ + +claimResultDecoder :: D.Row OutboxRow +claimResultDecoder = outboxRowDecoder + +countBacklogStmt :: Statement () Int +countBacklogStmt = + preparable + "SELECT COUNT(*)::bigint FROM keiro.keiro_outbox WHERE status IN ('pending', 'failed')" + E.noParams + (fmap fromIntegral (D.singleRow (D.column (D.nonNullable D.int8)))) + +gcSentStmt :: Statement UTCTime Int64 +gcSentStmt = + preparable + """ + WITH deleted AS ( + DELETE FROM keiro.keiro_outbox + WHERE status = 'sent' AND published_at < $1 + RETURNING 1 + ) + SELECT COALESCE(COUNT(*), 0)::bigint FROM deleted + """ + (E.param (E.nonNullable E.timestamptz)) + (D.singleRow (D.column (D.nonNullable D.int8))) + +readAttemptCountStmt :: Statement UUID (Maybe Int) +readAttemptCountStmt = + preparable + "SELECT attempt_count FROM keiro.keiro_outbox WHERE outbox_id = $1" + (E.param (E.nonNullable E.uuid)) + (D.rowMaybe (fromIntegral <$> D.column (D.nonNullable D.int8))) + +deadLetterStuckStmt :: Statement (UTCTime, Int64, UTCTime) Int64 +deadLetterStuckStmt = + preparable + """ + UPDATE keiro.keiro_outbox + SET status = 'dead', + last_error = COALESCE(last_error, 'reclaimed: publisher crashed mid-publish'), + updated_at = $3 + WHERE status = 'publishing' + AND updated_at <= $1 + AND attempt_count >= $2 + """ + ( contrazip3 + (E.param (E.nonNullable E.timestamptz)) + (E.param (E.nonNullable E.int8)) + (E.param (E.nonNullable E.timestamptz)) + ) + D.rowsAffected + +requeueStuckStmt :: Statement (UTCTime, Int64, UTCTime) Int64 +requeueStuckStmt = + preparable + """ + UPDATE keiro.keiro_outbox + SET status = 'failed', + updated_at = $3 + WHERE status = 'publishing' + AND updated_at <= $1 + AND attempt_count < $2 + """ + ( contrazip3 + (E.param (E.nonNullable E.timestamptz)) + (E.param (E.nonNullable E.int8)) + (E.param (E.nonNullable E.timestamptz)) + ) + D.rowsAffected + +markSentStmt :: Statement (UUID, UTCTime) Bool +markSentStmt = + preparable + """ + UPDATE keiro.keiro_outbox + SET status = 'sent', + published_at = $2, + last_error = NULL, + updated_at = $2 + WHERE outbox_id = $1 + AND status = 'publishing' + """ + ( contrazip2 + (E.param (E.nonNullable E.uuid)) + (E.param (E.nonNullable E.timestamptz)) + ) + ((> 0) <$> D.rowsAffected) + +markSentBatchStmt :: Statement ([UUID], UTCTime) Int64 +markSentBatchStmt = + preparable + """ + UPDATE keiro.keiro_outbox + SET status = 'sent', + published_at = $2, + last_error = NULL, + updated_at = $2 + WHERE outbox_id = ANY($1) + AND status = 'publishing' + """ + ( contrazip2 + (E.param (E.nonNullable (E.foldableArray (E.nonNullable E.uuid)))) + (E.param (E.nonNullable E.timestamptz)) + ) + D.rowsAffected + +markFailedStmt :: Statement (UUID, Text, Text, UTCTime, UTCTime) () +markFailedStmt = + preparable + """ + UPDATE keiro.keiro_outbox + SET status = $2, + last_error = $3, + next_attempt_at = $4, + updated_at = $5 + WHERE outbox_id = $1 + AND status = 'publishing' + """ + ( contrazip5 + (E.param (E.nonNullable E.uuid)) + (E.param (E.nonNullable E.text)) + (E.param (E.nonNullable E.text)) + (E.param (E.nonNullable E.timestamptz)) + (E.param (E.nonNullable E.timestamptz)) + ) + D.noResult + +markSkippedStmt :: Statement (UUID, Text, UTCTime) () +markSkippedStmt = + preparable + """ + UPDATE keiro.keiro_outbox + SET status = 'failed', + attempt_count = GREATEST(attempt_count - 1, 0), + last_error = $2, + next_attempt_at = $3, + updated_at = $3 + WHERE outbox_id = $1 + AND status = 'publishing' + """ + ( contrazip3 + (E.param (E.nonNullable E.uuid)) + (E.param (E.nonNullable E.text)) + (E.param (E.nonNullable E.timestamptz)) + ) + D.noResult + +lookupOutboxStmt :: Statement UUID (Maybe OutboxRow) +lookupOutboxStmt = + preparable + (selectAllSql <> " WHERE outbox_id = $1") + (E.param (E.nonNullable E.uuid)) + (D.rowMaybe outboxRowDecoder) + +listOutboxStmt :: Statement Text [OutboxRow] +listOutboxStmt = + preparable + (selectAllSql <> " WHERE source = $1 ORDER BY created_at, outbox_id") + (E.param (E.nonNullable E.text)) + (D.rowList outboxRowDecoder) + +selectAllSql :: Text +selectAllSql = + """ + SELECT outbox_id, message_id, source, destination, message_key, event_type, + schema_version, content_type, schema_registry, schema_subject, + schema_version_ref, schema_id, schema_fingerprint, source_event_id, + source_global_position, causation_id, correlation_id, traceparent, + tracestate, payload_bytes, attributes, occurred_at, status, + attempt_count, next_attempt_at, last_error, published_at, created_at, + updated_at + FROM keiro.keiro_outbox + """ + +outboxRowDecoder :: D.Row OutboxRow +outboxRowDecoder = fmap assembleRow rawRowDecoder + +data RawRow = RawRow + { outboxId :: !OutboxId, + messageId :: !Text, + source :: !Text, + destination :: !Text, + key :: !(Maybe Text), + eventType :: !Text, + schemaVersion :: !Int, + contentType :: !Text, + schemaRegistry :: !(Maybe Text), + schemaSubject :: !(Maybe Text), + schemaVersionRef :: !(Maybe Int), + schemaId :: !(Maybe Int64), + schemaFingerprint :: !(Maybe Text), + sourceEventId :: !(Maybe EventId), + sourceGlobalPosition :: !(Maybe GlobalPosition), + causationId :: !(Maybe EventId), + correlationId :: !(Maybe EventId), + traceparent :: !(Maybe Text), + tracestate :: !(Maybe Text), + payloadBytes :: !ByteString, + attributes :: !(Maybe Value), + occurredAt :: !UTCTime, + status :: !OutboxStatus, + attemptCount :: !Int, + nextAttemptAt :: !UTCTime, + lastError :: !(Maybe Text), + publishedAt :: !(Maybe UTCTime), + createdAt :: !UTCTime, + updatedAt :: !UTCTime + } + deriving stock (Generic) + +rawRowDecoder :: D.Row RawRow +rawRowDecoder = + RawRow + <$> (OutboxId <$> D.column (D.nonNullable D.uuid)) + <*> D.column (D.nonNullable D.text) + <*> D.column (D.nonNullable D.text) + <*> D.column (D.nonNullable D.text) + <*> D.column (D.nullable D.text) + <*> D.column (D.nonNullable D.text) + <*> (fromIntegral <$> D.column (D.nonNullable D.int8)) + <*> D.column (D.nonNullable D.text) + <*> D.column (D.nullable D.text) + <*> D.column (D.nullable D.text) + <*> (fmap fromIntegral <$> D.column (D.nullable D.int8)) + <*> D.column (D.nullable D.int8) + <*> D.column (D.nullable D.text) + <*> (fmap EventId <$> D.column (D.nullable D.uuid)) + <*> (fmap GlobalPosition <$> D.column (D.nullable D.int8)) + <*> (fmap EventId <$> D.column (D.nullable D.uuid)) + <*> (fmap EventId <$> D.column (D.nullable D.uuid)) + <*> D.column (D.nullable D.text) + <*> D.column (D.nullable D.text) + <*> D.column (D.nonNullable D.bytea) + <*> D.column (D.nullable D.jsonb) + <*> D.column (D.nonNullable D.timestamptz) + <*> D.column (D.nonNullable (D.refine parseStatus D.text)) + <*> (fromIntegral <$> D.column (D.nonNullable D.int8)) + <*> D.column (D.nonNullable D.timestamptz) + <*> D.column (D.nullable D.text) + <*> D.column (D.nullable D.timestamptz) + <*> D.column (D.nonNullable D.timestamptz) + <*> D.column (D.nonNullable D.timestamptz) + +assembleRow :: RawRow -> OutboxRow +assembleRow raw = + let traceContext = case raw ^. #traceparent of + Nothing -> Nothing + Just tp -> Just (TraceContext tp (raw ^. #tracestate)) + schemaReference = + case ( raw ^. #schemaRegistry, + raw ^. #schemaSubject, + raw ^. #schemaVersionRef, + raw ^. #schemaId, + raw ^. #schemaFingerprint + ) of + (Nothing, Nothing, Nothing, Nothing, Nothing) -> Nothing + _ -> + Just + ( SchemaReference + (raw ^. #schemaRegistry) + (raw ^. #schemaSubject) + (raw ^. #schemaVersionRef) + (raw ^. #schemaId) + (raw ^. #schemaFingerprint) + ) + event = + IntegrationEvent + { messageId = raw ^. #messageId, + source = raw ^. #source, + destination = raw ^. #destination, + key = raw ^. #key, + eventType = raw ^. #eventType, + schemaVersion = raw ^. #schemaVersion, + contentType = parseContentType (raw ^. #contentType), + schemaReference, + sourceEventId = raw ^. #sourceEventId, + sourceGlobalPosition = raw ^. #sourceGlobalPosition, + payloadBytes = raw ^. #payloadBytes, + occurredAt = raw ^. #occurredAt, + causationId = raw ^. #causationId, + correlationId = raw ^. #correlationId, + traceContext, + attributes = raw ^. #attributes + } + in OutboxRow + { outboxId = raw ^. #outboxId, + event, + status = raw ^. #status, + attemptCount = raw ^. #attemptCount, + nextAttemptAt = raw ^. #nextAttemptAt, + lastError = raw ^. #lastError, + publishedAt = raw ^. #publishedAt, + createdAt = raw ^. #createdAt, + updatedAt = raw ^. #updatedAt + } diff --git a/src/Keiro/Outbox/Types.hs b/src/Keiro/Outbox/Types.hs --- a/src/Keiro/Outbox/Types.hs +++ b/src/Keiro/Outbox/Types.hs @@ -1,13 +1,12 @@ -{- | Shared types for the durable integration-event outbox. - -The outbox is the durable handoff between "this service has decided to -publish this integration event" and "this service has actually published -it". The producer subscription writes one outbox row per mapped private -event; the publisher worker drains rows into Kafka and marks each one -sent, retryable, or dead. --} -module Keiro.Outbox.Types ( - OutboxId (..), +-- | Shared types for the durable integration-event outbox. +-- +-- The outbox is the durable handoff between "this service has decided to +-- publish this integration event" and "this service has actually published +-- it". The producer subscription writes one outbox row per mapped private +-- event; the publisher worker drains rows into Kafka and marks each one +-- sent, retryable, or dead. +module Keiro.Outbox.Types + ( OutboxId (..), OutboxStatus (..), OrderingPolicy (..), BackoffSchedule (..), @@ -25,7 +24,7 @@ statusText, parseStatus, nextDelay, -) + ) where import Data.Time.Clock (NominalDiffTime) @@ -37,241 +36,231 @@ -- | Primary key of a 'keiro_outbox' row. Stable across publish retries. newtype OutboxId = OutboxId {unOutboxId :: UUID} - deriving stock (Generic, Eq, Ord, Show) + deriving stock (Generic, Eq, Ord, Show) instance ToJSON OutboxId where - toJSON = toJSON . UUID.toText . unOutboxId + toJSON = toJSON . UUID.toText . unOutboxId instance FromJSON OutboxId where - parseJSON v = do - text <- parseJSON v - case UUID.fromText text of - Nothing -> fail ("OutboxId: not a UUID: " <> show text) - Just uuid -> pure (OutboxId uuid) - -{- | Lifecycle state of an outbox row. + parseJSON v = do + text <- parseJSON v + case UUID.fromText text of + Nothing -> fail ("OutboxId: not a UUID: " <> show text) + Just uuid -> pure (OutboxId uuid) -* 'OutboxPending' — never attempted. -* 'OutboxPublishing' — currently held by a publisher worker (between - claim and the call to mark sent/failed/dead). Rows left in this state - after a worker crash are reclaimed by 'Keiro.Outbox.outboxMaintenancePass' - after 'publishingTimeout'. -* 'OutboxSent' — Kafka acknowledged the publish; terminal. -* 'OutboxFailed' — last attempt failed; will be retried after - 'next_attempt_at'. -* 'OutboxDead' — terminal failure after 'maxAttempts' consecutive - failures. Stays in the table for operator inspection. --} +-- | Lifecycle state of an outbox row. +-- +-- * 'OutboxPending' — never attempted. +-- * 'OutboxPublishing' — currently held by a publisher worker (between +-- claim and the call to mark sent/failed/dead). Rows left in this state +-- after a worker crash are reclaimed by 'Keiro.Outbox.outboxMaintenancePass' +-- after 'publishingTimeout'. +-- * 'OutboxSent' — Kafka acknowledged the publish; terminal. +-- * 'OutboxFailed' — last attempt failed; will be retried after +-- 'next_attempt_at'. +-- * 'OutboxDead' — terminal failure after 'maxAttempts' consecutive +-- failures. Stays in the table for operator inspection. data OutboxStatus - = OutboxPending - | OutboxPublishing - | OutboxSent - | OutboxFailed - | OutboxDead - deriving stock (Generic, Eq, Show) - -{- | Ordering policy enforced by the publisher worker's claim query. + = OutboxPending + | OutboxPublishing + | OutboxSent + | OutboxFailed + | OutboxDead + deriving stock (Generic, Eq, Show) -* 'PerKeyHeadOfLine' (default) — within a @source@, a non-terminal row - with key @k@ blocks every later row with the same key. Rows with - 'Nothing' key bypass the block (Kafka does not promise cross-key order - for null-keyed records). One stuck aggregate cannot stall traffic on - other aggregates. Ordering is based on @created_at@, which PostgreSQL - sets to transaction-start time; callers that concurrently enqueue the - same key through escape hatches must serialize those enqueues themselves - if commit order matters. -* 'PerSourceStream' — within a @source@, any non-terminal row blocks - every later row. Use when ordering matters across keys (rare). This has - the same @created_at@ concurrency caveat as 'PerKeyHeadOfLine'. -* 'StopTheLine' — any failure halts the worker until operator - intervention. Use when correctness requires manual review on every - failure. -* 'BestEffort' — failed rows do not block; explicit opt-in only. Safe - only when published events have no per-key/causal relationship. --} +-- | Ordering policy enforced by the publisher worker's claim query. +-- +-- * 'PerKeyHeadOfLine' (default) — within a @source@, a non-terminal row +-- with key @k@ blocks every later row with the same key. Rows with +-- 'Nothing' key bypass the block (Kafka does not promise cross-key order +-- for null-keyed records). One stuck aggregate cannot stall traffic on +-- other aggregates. Ordering is based on @created_at@, which PostgreSQL +-- sets to transaction-start time; callers that concurrently enqueue the +-- same key through escape hatches must serialize those enqueues themselves +-- if commit order matters. +-- * 'PerSourceStream' — within a @source@, any non-terminal row blocks +-- every later row. Use when ordering matters across keys (rare). This has +-- the same @created_at@ concurrency caveat as 'PerKeyHeadOfLine'. +-- * 'StopTheLine' — any failure halts the worker until operator +-- intervention. Use when correctness requires manual review on every +-- failure. +-- * 'BestEffort' — failed rows do not block; explicit opt-in only. Safe +-- only when published events have no per-key/causal relationship. data OrderingPolicy - = PerKeyHeadOfLine - | PerSourceStream - | StopTheLine - | BestEffort - deriving stock (Generic, Eq, Show) + = PerKeyHeadOfLine + | PerSourceStream + | StopTheLine + | BestEffort + deriving stock (Generic, Eq, Show) -- | Knobs for 'ExponentialBackoff'. @delay = min maxDelay (initial * multiplier ^ (attempt - 1))@. data ExponentialBackoffOptions = ExponentialBackoffOptions - { initial :: !NominalDiffTime - , maxDelay :: !NominalDiffTime - , multiplier :: !Double - } - deriving stock (Generic, Eq, Show) - -{- | Backoff curve used to compute 'next_attempt_at' after a failure. + { initial :: !NominalDiffTime, + maxDelay :: !NominalDiffTime, + multiplier :: !Double + } + deriving stock (Generic, Eq, Show) -* 'ConstantBackoff' — fixed delay between retries. -* 'ExponentialBackoff' — exponential growth capped at @maxDelay@. --} +-- | Backoff curve used to compute 'next_attempt_at' after a failure. +-- +-- * 'ConstantBackoff' — fixed delay between retries. +-- * 'ExponentialBackoff' — exponential growth capped at @maxDelay@. data BackoffSchedule - = ConstantBackoff !NominalDiffTime - | ExponentialBackoff !ExponentialBackoffOptions - deriving stock (Generic, Eq, Show) + = ConstantBackoff !NominalDiffTime + | ExponentialBackoff !ExponentialBackoffOptions + deriving stock (Generic, Eq, Show) -{- | Compute the retry delay for an attempt number (1-based: 1 = first -failure, 2 = second failure, …). Used by 'Keiro.Outbox.Schema.markOutboxFailedTx' -to derive @next_attempt_at@. --} +-- | Compute the retry delay for an attempt number (1-based: 1 = first +-- failure, 2 = second failure, …). Used by 'Keiro.Outbox.Schema.markOutboxFailedTx' +-- to derive @next_attempt_at@. nextDelay :: BackoffSchedule -> Int -> NominalDiffTime nextDelay (ConstantBackoff delay) _ = delay nextDelay (ExponentialBackoff opts) attempt = - let raw = (opts ^. #initial) * realToFrac ((opts ^. #multiplier) ** fromIntegral (max 0 (attempt - 1))) - in min (opts ^. #maxDelay) raw + let raw = (opts ^. #initial) * realToFrac ((opts ^. #multiplier) ** fromIntegral (max 0 (attempt - 1))) + in min (opts ^. #maxDelay) raw -{- | A request to enqueue one integration event into the outbox. Callers -generate 'outboxId' (use a random UUID for ad-hoc enqueues, a -deterministic UUID for idempotent retries from a saga/process manager). --} +-- | A request to enqueue one integration event into the outbox. Callers +-- generate 'outboxId' (use a random UUID for ad-hoc enqueues, a +-- deterministic UUID for idempotent retries from a saga/process manager). data OutboxMessage = OutboxMessage - { outboxId :: !OutboxId - , event :: !IntegrationEvent - } - deriving stock (Generic, Eq, Show) + { outboxId :: !OutboxId, + event :: !IntegrationEvent + } + deriving stock (Generic, Eq, Show) -{- | A row read back from @keiro_outbox@. Worker code consumes these to -publish to Kafka; tests use them to assert state transitions. --} +-- | A row read back from @keiro_outbox@. Worker code consumes these to +-- publish to Kafka; tests use them to assert state transitions. data OutboxRow = OutboxRow - { outboxId :: !OutboxId - , event :: !IntegrationEvent - , status :: !OutboxStatus - , attemptCount :: !Int - , nextAttemptAt :: !UTCTime - , lastError :: !(Maybe Text) - , publishedAt :: !(Maybe UTCTime) - , createdAt :: !UTCTime - , updatedAt :: !UTCTime - } - deriving stock (Generic, Eq, Show) - -{- | Knobs that govern one invocation of 'Keiro.Outbox.publishClaimedOutbox'. + { outboxId :: !OutboxId, + event :: !IntegrationEvent, + status :: !OutboxStatus, + attemptCount :: !Int, + nextAttemptAt :: !UTCTime, + lastError :: !(Maybe Text), + publishedAt :: !(Maybe UTCTime), + createdAt :: !UTCTime, + updatedAt :: !UTCTime + } + deriving stock (Generic, Eq, Show) -The optional 'tracer' field opts the publisher into OpenTelemetry -instrumentation: when present, the publisher opens a @Producer@-kind -span around each publish call, attributing the first row's -'IntegrationEvent.destination' (topic), 'IntegrationEvent.messageId', -and Kafka key per the messaging semantic conventions. When 'tracer' is -'Nothing' (the default) the publisher emits no spans. --} +-- | Knobs that govern one invocation of 'Keiro.Outbox.publishClaimedOutbox'. +-- +-- The optional 'tracer' field opts the publisher into OpenTelemetry +-- instrumentation: when present, the publisher opens a @Producer@-kind +-- span around each publish call, attributing the first row's +-- 'IntegrationEvent.destination' (topic), 'IntegrationEvent.messageId', +-- and Kafka key per the messaging semantic conventions. When 'tracer' is +-- 'Nothing' (the default) the publisher emits no spans. data OutboxPublishOptions = OutboxPublishOptions - { batchSize :: !Int - , maxAttempts :: !Int - , backoff :: !BackoffSchedule - , orderingPolicy :: !OrderingPolicy - , publishingTimeout :: !NominalDiffTime - , tracer :: !(Maybe Tracer) - } - deriving stock (Generic) + { batchSize :: !Int, + maxAttempts :: !Int, + backoff :: !BackoffSchedule, + orderingPolicy :: !OrderingPolicy, + publishingTimeout :: !NominalDiffTime, + tracer :: !(Maybe Tracer) + } + deriving stock (Generic) data OutboxPublishConfigError - = InvalidOutboxBatchSize !Int - | InvalidOutboxMaxAttempts !Int - | InvalidOutboxPublishingTimeout !NominalDiffTime - | InvalidConstantBackoff !NominalDiffTime - | InvalidExponentialBackoffInitial !NominalDiffTime - | InvalidExponentialBackoffMultiplier !Double - | InvalidExponentialBackoffMaxDelay !NominalDiffTime !NominalDiffTime - deriving stock (Generic, Eq, Show) - -{- | Aggregate result of one publisher pass. + = InvalidOutboxBatchSize !Int + | InvalidOutboxMaxAttempts !Int + | InvalidOutboxPublishingTimeout !NominalDiffTime + | InvalidConstantBackoff !NominalDiffTime + | InvalidExponentialBackoffInitial !NominalDiffTime + | InvalidExponentialBackoffMultiplier !Double + | InvalidExponentialBackoffMaxDelay !NominalDiffTime !NominalDiffTime + deriving stock (Generic, Eq, Show) -@published + retried + dead@ equals the number of rows claimed. 'retried' -includes rows that were skipped because an earlier row in the same ordered -publish group failed; those rows are returned to @failed@ without consuming -an attempt. 'haltedOn' is populated only by 'StopTheLine' policy and names -the failed pivot row, which is already counted in 'retried' or 'dead'. --} +-- | Aggregate result of one publisher pass. +-- +-- @published + retried + dead@ equals the number of rows claimed. 'retried' +-- includes rows that were skipped because an earlier row in the same ordered +-- publish group failed; those rows are returned to @failed@ without consuming +-- an attempt. 'haltedOn' is populated only by 'StopTheLine' policy and names +-- the failed pivot row, which is already counted in 'retried' or 'dead'. data OutboxPublishSummary = OutboxPublishSummary - { claimed :: !Int - , published :: !Int - , retried :: !Int - , dead :: !Int - , haltedOn :: !(Maybe OutboxId) - } - deriving stock (Generic, Eq, Show) - -{- | Knobs for 'Keiro.Outbox.outboxMaintenancePass'. + { claimed :: !Int, + published :: !Int, + retried :: !Int, + dead :: !Int, + haltedOn :: !(Maybe OutboxId) + } + deriving stock (Generic, Eq, Show) -Schedule maintenance less frequently than publish passes; it owns crash -reclamation and backlog gauge sampling. --} +-- | Knobs for 'Keiro.Outbox.outboxMaintenancePass'. +-- +-- Schedule maintenance less frequently than publish passes; it owns crash +-- reclamation and backlog gauge sampling. data OutboxMaintenanceOptions = OutboxMaintenanceOptions - { maxAttempts :: !Int - , publishingTimeout :: !NominalDiffTime - } - deriving stock (Generic, Eq, Show) + { maxAttempts :: !Int, + publishingTimeout :: !NominalDiffTime + } + deriving stock (Generic, Eq, Show) -- | Result of one outbox maintenance pass. data OutboxMaintenanceSummary = OutboxMaintenanceSummary - { requeued :: !Int - , deadLettered :: !Int - , backlog :: !Int - } - deriving stock (Generic, Eq, Show) + { requeued :: !Int, + deadLettered :: !Int, + backlog :: !Int + } + deriving stock (Generic, Eq, Show) -{- | Sensible defaults: batch of 32, ten retry attempts, two-second -constant backoff, per-key head-of-line ordering. --} +-- | Sensible defaults: batch of 32, ten retry attempts, two-second +-- constant backoff, per-key head-of-line ordering. defaultPublishOptions :: OutboxPublishOptions defaultPublishOptions = - OutboxPublishOptions - { batchSize = 32 - , maxAttempts = 10 - , backoff = ConstantBackoff 2 - , orderingPolicy = PerKeyHeadOfLine - , publishingTimeout = 300 - , tracer = Nothing - } + OutboxPublishOptions + { batchSize = 32, + maxAttempts = 10, + backoff = ConstantBackoff 2, + orderingPolicy = PerKeyHeadOfLine, + publishingTimeout = 300, + tracer = Nothing + } -- | Maintenance defaults match the publisher's retry ceiling and stale-row timeout. defaultMaintenanceOptions :: OutboxMaintenanceOptions defaultMaintenanceOptions = - OutboxMaintenanceOptions - { maxAttempts = defaultPublishOptions ^. #maxAttempts - , publishingTimeout = defaultPublishOptions ^. #publishingTimeout - } + OutboxMaintenanceOptions + { maxAttempts = defaultPublishOptions ^. #maxAttempts, + publishingTimeout = defaultPublishOptions ^. #publishingTimeout + } -- | Validate outbox publisher options before starting a worker. mkOutboxPublishOptions :: OutboxPublishOptions -> Either OutboxPublishConfigError OutboxPublishOptions mkOutboxPublishOptions opts - | opts ^. #batchSize < 1 = Left (InvalidOutboxBatchSize (opts ^. #batchSize)) - | opts ^. #maxAttempts < 1 = Left (InvalidOutboxMaxAttempts (opts ^. #maxAttempts)) - | opts ^. #publishingTimeout <= 0 = Left (InvalidOutboxPublishingTimeout (opts ^. #publishingTimeout)) - | otherwise = opts <$ validateBackoff (opts ^. #backoff) + | opts ^. #batchSize < 1 = Left (InvalidOutboxBatchSize (opts ^. #batchSize)) + | opts ^. #maxAttempts < 1 = Left (InvalidOutboxMaxAttempts (opts ^. #maxAttempts)) + | opts ^. #publishingTimeout <= 0 = Left (InvalidOutboxPublishingTimeout (opts ^. #publishingTimeout)) + | otherwise = opts <$ validateBackoff (opts ^. #backoff) validateBackoff :: BackoffSchedule -> Either OutboxPublishConfigError () validateBackoff = \case - ConstantBackoff delay - | delay < 0 -> Left (InvalidConstantBackoff delay) - | otherwise -> Right () - ExponentialBackoff backoff - | backoff ^. #initial <= 0 -> Left (InvalidExponentialBackoffInitial (backoff ^. #initial)) - | backoff ^. #multiplier < 1 -> Left (InvalidExponentialBackoffMultiplier (backoff ^. #multiplier)) - | backoff ^. #maxDelay < backoff ^. #initial -> - Left (InvalidExponentialBackoffMaxDelay (backoff ^. #initial) (backoff ^. #maxDelay)) - | otherwise -> Right () + ConstantBackoff delay + | delay < 0 -> Left (InvalidConstantBackoff delay) + | otherwise -> Right () + ExponentialBackoff backoff + | backoff ^. #initial <= 0 -> Left (InvalidExponentialBackoffInitial (backoff ^. #initial)) + | backoff ^. #multiplier < 1 -> Left (InvalidExponentialBackoffMultiplier (backoff ^. #multiplier)) + | backoff ^. #maxDelay < backoff ^. #initial -> + Left (InvalidExponentialBackoffMaxDelay (backoff ^. #initial) (backoff ^. #maxDelay)) + | otherwise -> Right () -- | Wire representation of 'OutboxStatus' used in the @status@ column. statusText :: OutboxStatus -> Text statusText = \case - OutboxPending -> "pending" - OutboxPublishing -> "publishing" - OutboxSent -> "sent" - OutboxFailed -> "failed" - OutboxDead -> "dead" + OutboxPending -> "pending" + OutboxPublishing -> "publishing" + OutboxSent -> "sent" + OutboxFailed -> "failed" + OutboxDead -> "dead" -- | Inverse of 'statusText'. Unknown database values are decode failures. parseStatus :: Text -> Either Text OutboxStatus parseStatus = \case - "pending" -> Right OutboxPending - "publishing" -> Right OutboxPublishing - "sent" -> Right OutboxSent - "failed" -> Right OutboxFailed - "dead" -> Right OutboxDead - bad -> Left ("unknown keiro_outbox.status: " <> bad) + "pending" -> Right OutboxPending + "publishing" -> Right OutboxPublishing + "sent" -> Right OutboxSent + "failed" -> Right OutboxFailed + "dead" -> Right OutboxDead + bad -> Left ("unknown keiro_outbox.status: " <> bad) diff --git a/src/Keiro/ProcessManager.hs b/src/Keiro/ProcessManager.hs --- a/src/Keiro/ProcessManager.hs +++ b/src/Keiro/ProcessManager.hs @@ -1,731 +1,717 @@ -{- | Stateful coordination across aggregates: the process manager (saga). - -A 'ProcessManager' reacts to an incoming event by stepping its /own/ state -machine — a private \"manager\" event stream, keyed by a correlation id — and, -in the same turn, dispatching commands to /target/ aggregates and scheduling -timers. It is the stateful counterpart of "Keiro.Router": where a router -resolves targets from a read model and holds no state, a process manager -folds the events it has seen into durable manager state and decides what to -do next from that state. - -Every write — the manager-state append, each dispatched command, each timer -— is keyed by a 'deterministicCommandId' derived from -@(name, correlation, source event id, emit index)@. The manager pre-checks -each id with 'eventAlreadyIn' and folds the store's duplicate rejection into -a benign 'PMCommandDuplicate' \/ 'PMStateDuplicate'. Replaying the same -source event therefore appends nothing new, which is what makes the worker -crash-safe under at-least-once delivery. - -Use 'runProcessManagerOnce' to react to a single event, or -'runProcessManagerWorker' to run the manager as a live subscription over a -Shibuya adapter. Worker acks are finalized exactly once: successful and duplicate -dispatches ack 'AckOk', transient store failures retry, systemic deterministic -failures halt, rejection-class failures follow 'RejectedCommandPolicy', and -undecodable messages follow the configured 'PoisonPolicy'. - -=== Rejected commands and saga history - -'RejectedHalt' is the safe default: the subscription stops without advancing, -so an operator cannot miss the failure. 'RejectedDeadLetter' instead writes a -durable "Keiro.DeadLetter.DispatchDeadLetter" and acknowledges the source -event; 'RejectedSkip' acknowledges and records only the metric. Prefer making a -target command total in its Keiki transducer (for example, an explicit no-op -transition for a benign business rejection) so no policy escape hatch is -needed. - -For a process manager, dead-lettering a target dispatch creates an important -history split: the manager's own state stream has recorded its reaction, but -the target command never applied. Keiro cannot append a generic correction to -the manager stream because an event unknown to the manager's transducer would -make that stream fail replay. If saga history must reflect the failure, model a -domain-specific @DispatchFailed@-style command and event in the manager and -drive it from 'Keiro.DeadLetter.listDispatchDeadLetters' through an operator -runbook or automation. Otherwise, the dead-letter row is the durable witness. -Manager-state rejection itself has no such split because no manager event was -appended; its record uses emit index @-1@. - -=== Bounded retries and source-event dead letters - -On a Kiroku-backed Shibuya adapter, a transient failure finalizes 'AckRetry', -but retries are bounded by the Kiroku subscription's @RetryPolicy@. Its -@retryMaxAttempts@ counts total deliveries and defaults to five. When the bound -is exhausted, Kiroku records the /source event/ in @kiroku.dead_letters@ with -structured reason kind @max_attempts_exceeded@ and atomically advances the -checkpoint. The manager will not see that event again unless an operator -replays it through @Keiro.DeadLetter.Replay@. Install -'Keiro.Telemetry.kirokuEventBridge' on Kiroku's @eventHandler@ to observe the -terminal transition. - -The adapter's @KirokuAdapterConfig@ does not currently expose @retryPolicy@, so -that path uses Kiroku's default bound. The sharded path is configurable: -'Keiro.Subscription.Shard.Worker.runShardedSubscriptionGroupAck' forwards -'Keiro.Subscription.Shard.Worker.ShardedWorkerOptions.retryPolicy' into the -same Kiroku acknowledgement ladder. A shard handler that dispatches commands -can use 'decideForFailures' and 'isRejectionClass' to classify outcomes, then -map the decision to its existing @ShardAck@ reply. - -=== Correlation, ordering, and transaction boundaries - -Events from one originating stream retain that stream's append order. Kiroku -consumer groups hash the originating stream id to a stable member, so sharding -does not split one stream across readers. Events from /different/ streams that -'correlate' to the same manager instance have no business-order guarantee, -however. Their append transactions race for global positions and, under -sharding, the streams may be processed concurrently by different members. A -retry on one member does not stop another member from advancing. - -For example, both @payment-ORD1@'s @PaymentCaptured@ and @shipment-ORD1@'s -@ShipmentAllocated@ may correlate to order @ORD1@. The manager must accept -@PaymentCaptured@ then @ShipmentAllocated@ /and/ the reverse, normally with -states that record one fact while waiting for the other. An unsharded Kiroku -subscription processes its observed global order serially, including retries, -but that order still reflects append timing rather than a domain sequence. - -Rule of thumb: 'correlate' may join streams freely, but every such join must be -order-insensitive. When a strict sequence is required, enforce it in the -manager's own state machine — for example with an explicit no-op/waiting state -and a timer-driven retry, or a modeled rejection handled by the dead-letter -policy — never by assuming delivery order. - -The persistence boundary is also intentionally smaller than one whole saga -reaction. A manager event and its timers commit together when the manager -command appends; a timer-only no-op reaction schedules its timers in a separate -transaction. Each target command and its inline projections then commit in -their own transaction. A crash or rejected target can therefore leave durable -manager history without every target write. Deterministic ids make source-event -replay fill the missing writes without duplicating completed ones; the rejected -command section above describes the case that is deliberately acknowledged -instead. --} -module Keiro.ProcessManager ( - -- * Definition - ProcessManager (..), - ProcessManagerAction (..), - PMCommand (..), - - -- * Results - ProcessManagerResult (..), - PMCommandResult (..), - PMStateResult (..), - - -- * Running - PoisonPolicy (..), - RejectedCommandPolicy (..), - DispatchFailure (..), - WorkerOptions (..), - defaultWorkerOptions, - isTransientStoreError, - isTransientCommandError, - isRejectionClass, - decideForFailures, - ackForCommandError, - runProcessManagerOnce, - runProcessManagerWorkerWith, - runProcessManagerWorker, - - -- * Idempotency primitives - deterministicCommandId, - eventAlreadyIn, - confirmBenignDuplicate, -) -where - -import Data.Coerce (coerce) -import Data.Text qualified as Text -import Data.UUID qualified as UUID -import Data.UUID.V5 qualified as UUID.V5 -import Effectful (Eff, IOE, (:>)) -import Effectful.Error.Static (Error, tryError) -import GHC.Stack (HasCallStack) -import Keiki.Core (BoolAlg, RegFile) -import Keiro.Command (CommandError (..), CommandResult, RunCommandOptions, commandErrorClass, runCommandWithSql) -import Keiro.DeadLetter (DispatchDeadLetter (..), DispatcherKind (..), recordDispatchDeadLetter) -import Keiro.EventStream (EventStream) -import Keiro.EventStream.Validate (ValidatedEventStream, unvalidated) -import Keiro.Prelude -import Keiro.Projection (InlineProjection, runCommandWithProjections) -import Keiro.Stream (Stream) -import Keiro.Telemetry (KeiroMetrics, recordDispatchDeadLettered, recordDispatchDuplicate, recordDispatchFailed, recordDispatchPoison) -import Keiro.Timer (TimerRequest, scheduleTimerTx) -import Kiroku.Store.Effect (Store) -import Kiroku.Store.Effect.Resource (KirokuStoreResource) -import Kiroku.Store.Error (StoreError (..)) -import Kiroku.Store.Read (eventExistsInStream) -import Kiroku.Store.Transaction (runTransaction) -import Kiroku.Store.Types (EventId (..), RecordedEvent) -import Kiroku.Store.Types qualified as StoreTypes -import Shibuya.Adapter (Adapter (..)) -import Shibuya.Core.Ack (AckDecision (..), DeadLetterReason (..), HaltReason (..), RetryDelay (..)) -import Shibuya.Core.AckHandle (AckHandle (..)) -import Shibuya.Core.Ingested (Ingested (..)) -import Shibuya.Core.Types (Attempt (..), Envelope (..)) -import Streamly.Data.Fold qualified as Fold -import Streamly.Data.Stream qualified as Streamly -import Prelude (any, filter, fromIntegral, length, not, uncurry, zip, (&&), (+)) - -{- | A process manager wiring together a manager state machine and the target -aggregate it drives. - -* 'name' — stable identity; part of every deterministic write id. -* 'correlate' — derives the correlation key for an input event, selecting - which manager instance handles it. -* 'eventStream' — the manager's own 'EventStream'; its events record the - saga's progress. -* 'streamFor' — maps a correlation key to the manager's 'Stream' handle. -* 'targetEventStream' — the aggregate that dispatched commands are sent to. -* 'targetProjections' — inline projections for the target aggregate, run in - the same transaction as each dispatched command's append. Return @[]@ for - append-only dispatch. -* 'handle' — the pure reaction: given an input event, produce the - manager-state command, the target commands to dispatch, and any timers to - schedule. --} -data ProcessManager input phi rs s ci co targetPhi targetRs targetState targetCi targetCo = ProcessManager - { name :: !Text - , correlate :: !(input -> Text) - , eventStream :: !(ValidatedEventStream phi rs s ci co) - , streamFor :: !(Text -> Stream (EventStream phi rs s ci co)) - , targetEventStream :: !(ValidatedEventStream targetPhi targetRs targetState targetCi targetCo) - , targetProjections :: !(Stream targetCi -> [InlineProjection targetCo]) - {- ^ Inline projections for the target aggregate, run in the same transaction - as each dispatched command's append. Return @[]@ for append-only dispatch. - -} - , handle :: !(input -> ProcessManagerAction ci targetCi) - } - deriving stock (Generic) - -{- | What a process manager decides to do for one input event: advance its own -state with 'command', dispatch zero or more target 'commands', and schedule -zero or more 'timers'. All three are applied atomically with crash-safe -idempotency by 'runProcessManagerOnce'. --} -data ProcessManagerAction ci targetCi = ProcessManagerAction - { command :: !ci - , commands :: ![PMCommand targetCi] - , timers :: ![TimerRequest] - } - deriving stock (Generic) - --- | A single command addressed to a specific target stream. -data PMCommand targetCi = PMCommand - { target :: !(Stream targetCi) - , command :: !targetCi - } - deriving stock (Generic, Eq, Show) - --- | Outcome of one dispatched target command. -data PMCommandResult target - = -- | The command appended events (carries the 'CommandResult'). - PMCommandAppended !(CommandResult target) - | {- | The command was already applied (idempotent replay); carries the - deterministic id that already existed. - -} - PMCommandDuplicate !EventId - | {- | The command failed in the named target stream; the worker classifies - the error. Transient failures retry, rejection-class failures follow - 'RejectedCommandPolicy', and systemic deterministic failures halt. - -} - PMCommandFailed !StoreTypes.StreamName !CommandError - deriving stock (Generic, Eq, Show) - -{- | Outcome of the manager's own state append. Unlike 'PMCommandResult' there -is no failure case — a manager-state append that genuinely errors aborts the -whole reaction via an outer @Left@ 'CommandError'. --} -data PMStateResult target - = PMStateAppended !(CommandResult target) - | PMStateDuplicate !EventId - deriving stock (Generic, Eq, Show) - -{- | The complete result of reacting to one event: how the manager state -advanced, the outcome of each dispatched command in order, and how many -timers were scheduled. --} -data ProcessManagerResult managerTarget commandTarget = ProcessManagerResult - { managerResult :: !(PMStateResult managerTarget) - , commandResults :: ![PMCommandResult commandTarget] - , timersScheduled :: !Int - } - deriving stock (Generic, Eq, Show) - --- | What a worker does with a message its decoder cannot parse. -data PoisonPolicy es msg - = PoisonHalt - | PoisonSkip !(Envelope msg -> Eff es ()) - | PoisonDeadLetter !(Envelope msg -> Eff es ()) - --- | What a worker does when every failed dispatch is a rejection-class error. -data RejectedCommandPolicy - = -- | Halt without acknowledging so the source event replays. This is the default. - RejectedHalt - | -- | Persist a durable dispatch dead letter and acknowledge the source event. - RejectedDeadLetter - | -- | Acknowledge and count the rejection without persisting a record. - RejectedSkip - deriving stock (Generic, Eq, Show) - --- | One failed dispatch with the target identity needed by worker policy. -data DispatchFailure = DispatchFailure - { emitIndex :: !Int - , targetStreamName :: !StoreTypes.StreamName - , commandError :: !CommandError - } - deriving stock (Generic, Eq, Show) - --- | Worker-level knobs shared by the process-manager and router workers. -data WorkerOptions es msg = WorkerOptions - { poisonPolicy :: !(PoisonPolicy es msg) - , rejectedCommandPolicy :: !RejectedCommandPolicy - , transientRetryDelay :: !RetryDelay - , metrics :: !(Maybe KeiroMetrics) - } - deriving stock (Generic) - -defaultWorkerOptions :: WorkerOptions es msg -defaultWorkerOptions = - WorkerOptions - { poisonPolicy = PoisonHalt - , rejectedCommandPolicy = RejectedHalt - , transientRetryDelay = RetryDelay 5 - , metrics = Nothing - } - -isTransientStoreError :: StoreError -> Bool -isTransientStoreError = \case - ConnectionLost{} -> True - PoolAcquisitionTimeout -> True - ConnectionError{} -> True - WrongExpectedVersion{} -> True - StreamAlreadyExists{} -> True - EmptyAppendBatch{} -> False - StreamNotFound{} -> False - ReservedStreamName{} -> False - StreamNameTooLong{} -> False - DuplicateEvent{} -> False - EventAlreadyLinked{} -> False - LinkSourceEventMissing{} -> False - UnexpectedServerError{} -> False - -isTransientCommandError :: CommandError -> Bool -isTransientCommandError = \case - StoreFailed err -> isTransientStoreError err - RetryExhausted _ err -> isTransientStoreError err - ConflictFixpoint _ err -> isTransientStoreError err - HydrationDecodeFailed{} -> False - HydrationReplayFailed{} -> False - HydrationGapDetected{} -> False - CommandRejected -> False - CommandAmbiguous{} -> False - EncodeFailed{} -> False - --- | Whether a command error is a per-command rejection covered by worker policy. -isRejectionClass :: CommandError -> Bool -isRejectionClass = \case - CommandRejected -> True - CommandAmbiguous{} -> True - _ -> False - -{- | Classify a group of failed dispatches and choose one acknowledgement. - -Systemic deterministic errors always halt. Any transient error retries the -whole source event. Only an all-rejection group reaches the configured -'RejectedCommandPolicy'. Dead-letter writes are idempotent under redelivery. --} -decideForFailures :: - (IOE :> es, Store :> es) => - WorkerOptions es msg -> - DispatcherKind -> - Text -> - Text -> - RecordedEvent -> - Int -> - [DispatchFailure] -> - Eff es AckDecision -decideForFailures workerOptions dispatcherKind dispatcherName correlationId sourceEvent attemptCount failures = - case filter isSystemicDeterministic failures of - failure : _ -> pure (haltFor failure) - [] - | any (isTransientCommandError . (^. #commandError)) failures -> - pure (AckRetry (workerOptions ^. #transientRetryDelay)) - | otherwise -> - case failures of - [] -> pure AckOk - _ -> decideRejected - where - isSystemicDeterministic failure = - let err = failure ^. #commandError - in not (isTransientCommandError err) && not (isRejectionClass err) - - haltFor failure = - AckHalt (HaltFatal (Text.pack (show (failure ^. #commandError)))) - - decideRejected = - case workerOptions ^. #rejectedCommandPolicy of - RejectedHalt -> pure (haltFor (headFailure failures)) - RejectedDeadLetter -> do - traverse_ recordFailure failures - recordHandled - pure AckOk - RejectedSkip -> do - recordHandled - pure AckOk - - recordHandled = - recordDispatchDeadLettered - (workerOptions ^. #metrics) - (fromIntegral (length failures)) - - recordFailure failure = - let err = failure ^. #commandError - in recordDispatchDeadLetter - DispatchDeadLetter - { dispatcherKind = dispatcherKind - , dispatcherName = dispatcherName - , correlationId = correlationId - , sourceEventId = sourceEvent ^. #eventId - , sourceGlobalPosition = sourceEvent ^. #globalPosition - , emitIndex = failure ^. #emitIndex - , targetStreamName = failure ^. #targetStreamName - , errorClass = commandErrorClass err - , errorDetail = Text.pack (show err) - , attemptCount = max 1 attemptCount - } - - headFailure = \case - failure : _ -> failure - [] -> DispatchFailure (-1) (StoreTypes.StreamName "unknown") CommandRejected - -ackForCommandError :: RetryDelay -> CommandError -> AckDecision -ackForCommandError delay err - | isTransientCommandError err = AckRetry delay - | otherwise = AckHalt (HaltFatal (Text.pack (show err))) - -{- | Derive a stable, collision-resistant 'EventId' for a manager write from -@(manager name, correlation id, source event id, emit index)@ via a v5 UUID. - -The same inputs always yield the same id, so a replayed source event -produces the same write ids and the store's uniqueness constraint collapses -the duplicate. The manager-state append uses an emit index of @-1@ to keep -it distinct from the dispatched commands (which start at @0@). This positional -index is sound because 'handle' is pure and therefore returns the same command -order for the same input. The effectful router uses -'Keiro.Router.deterministicRouterCommandId' instead, retaining this positional -id only as a transition probe for pre-upgrade router dispatches. --} -deterministicCommandId :: Text -> Text -> EventId -> Int -> EventId -deterministicCommandId managerName correlationId sourceEventId emitIndex = - EventId - $ UUID.V5.generateNamed UUID.V5.namespaceURL - $ fmap (fromIntegral . fromEnum) - $ Text.unpack - $ Text.intercalate - ":" - [ "keiro" - , "process-manager" - , managerName - , correlationId - , UUID.toText (eventIdToUuid sourceEventId) - , Text.pack (show emitIndex) - ] - -{- | React to a single source event: advance the manager's state, dispatch -its target commands, and schedule its timers — each under a deterministic, -idempotent write id. - -The manager-state append and its timers commit in one transaction; each -target command is then dispatched (with its inline projections) in its own. -A duplicate manager append short-circuits to 'PMStateDuplicate' but still -re-runs the dispatch loop, so a crash between the state append and a -command dispatch is recovered on replay. Returns @Left@ only when the -manager-state append fails for a non-duplicate reason; per-command failures -are reported inside 'commandResults'. --} -runProcessManagerOnce :: - forall input phi rs s ci co targetPhi targetRs targetState targetCi targetCo es. - ( HasCallStack - , IOE :> es - , Store :> es - , Error StoreError :> es - , KirokuStoreResource :> es - , BoolAlg phi (RegFile rs, ci) - , BoolAlg targetPhi (RegFile targetRs, targetCi) - , Eq co - , Eq targetCo - ) => - RunCommandOptions -> - ProcessManager input phi rs s ci co targetPhi targetRs targetState targetCi targetCo -> - RecordedEvent -> - input -> - Eff es (Either CommandError (ProcessManagerResult (EventStream phi rs s ci co) (EventStream targetPhi targetRs targetState targetCi targetCo))) -runProcessManagerOnce options manager sourceEvent input = do - let correlationId = (manager ^. #correlate) input - action = (manager ^. #handle) input - managerStream = (manager ^. #streamFor) correlationId - managerEventId = deterministicCommandId (manager ^. #name) correlationId (sourceEvent ^. #eventId) (-1) - managerOptions = options & #eventIds .~ [managerEventId] - managerStreamName = ((unvalidated (manager ^. #eventStream)) ^. #resolveStreamName) managerStream - managerAlreadyProcessed <- eventAlreadyIn options managerStreamName managerEventId - if managerAlreadyProcessed - then finish correlationId (PMStateDuplicate managerEventId) action - else do - managerOutcome <- - runCommandWithSql - managerOptions - (manager ^. #eventStream) - managerStream - (action ^. #command) - (\_ -> traverse_ scheduleTimerTx (action ^. #timers)) - case managerOutcome of - Left err -> do - benign <- confirmBenignDuplicate managerStreamName managerEventId err - if benign - then finish correlationId (PMStateDuplicate managerEventId) action - else pure (Left err) - Right (managerResult, scheduledInAppend) -> do - -- No-op manager commands do not execute runCommandWithSql's callback, - -- so schedule timer-only reactions explicitly. - case scheduledInAppend of - Nothing -> runTransaction (traverse_ scheduleTimerTx (action ^. #timers)) - Just () -> pure () - finish correlationId (PMStateAppended managerResult) action - where - finish correlationId managerResult action = do - commandResults <- dispatchCommands correlationId (sourceEvent ^. #eventId) (action ^. #commands) - pure - $ Right - ProcessManagerResult - { managerResult = managerResult - , commandResults = commandResults - , timersScheduled = length (action ^. #timers) - } - - dispatchCommands correlationId sourceEventId commands = - traverse - (uncurry (dispatchCommand correlationId sourceEventId)) - (zip [0 ..] commands) - - dispatchCommand correlationId sourceEventId emitIndex command = do - let commandId = deterministicCommandId (manager ^. #name) correlationId sourceEventId emitIndex - targetOptions = options & #eventIds .~ [commandId] - targetStream = retarget (command ^. #target) - targetStreamName = ((unvalidated (manager ^. #targetEventStream)) ^. #resolveStreamName) targetStream - commandAlreadyProcessed <- eventAlreadyIn options targetStreamName commandId - if commandAlreadyProcessed - then pure (PMCommandDuplicate commandId) - else do - outcome <- - runCommandWithProjections - targetOptions - (manager ^. #targetEventStream) - targetStream - (command ^. #command) - ((manager ^. #targetProjections) (command ^. #target)) - case outcome of - Right result -> pure (PMCommandAppended result) - Left err -> do - benign <- confirmBenignDuplicate targetStreamName commandId err - pure $ if benign then PMCommandDuplicate commandId else PMCommandFailed targetStreamName err - - retarget :: Stream targetCi -> Stream (EventStream targetPhi targetRs targetState targetCi targetCo) - retarget = coerce - -{- | Run a process manager as a live subscription draining a Shibuya adapter with -'defaultWorkerOptions'. - -Use 'runProcessManagerWorkerWith' to override poison-message handling, rejected -command handling, transient retry delay, or dispatch metrics. Every ingested message's ack handle is -finalized exactly once. Successful and duplicate dispatches finalize 'AckOk'; -transient store failures finalize 'AckRetry'; rejection-class failures follow -'RejectedCommandPolicy'; other deterministic failures finalize 'AckHalt'; -undecodable messages follow the configured 'PoisonPolicy'. Under -'RejectedDeadLetter', see the module-level saga-history contract before opting -in. On a Kiroku-backed adapter, each 'AckRetry' redelivery is bounded by the -subscription @RetryPolicy@ (five total deliveries by default). Exhaustion -dead-letters the source event in @kiroku.dead_letters@ and advances the -checkpoint; @KirokuAdapterConfig@ does not currently expose that bound. Observe -the terminal event with 'Keiro.Telemetry.kirokuEventBridge' and replay it with -@Keiro.DeadLetter.Replay@ when appropriate. --} -runProcessManagerWorker :: - forall msg input phi rs s ci co targetPhi targetRs targetState targetCi targetCo es. - ( HasCallStack - , IOE :> es - , Store :> es - , Error StoreError :> es - , KirokuStoreResource :> es - , BoolAlg phi (RegFile rs, ci) - , BoolAlg targetPhi (RegFile targetRs, targetCi) - , Eq co - , Eq targetCo - ) => - RunCommandOptions -> - ProcessManager input phi rs s ci co targetPhi targetRs targetState targetCi targetCo -> - Adapter es msg -> - (msg -> Maybe (RecordedEvent, input)) -> - Eff es () -runProcessManagerWorker = - runProcessManagerWorkerWith defaultWorkerOptions - -runProcessManagerWorkerWith :: - forall msg input phi rs s ci co targetPhi targetRs targetState targetCi targetCo es. - ( HasCallStack - , IOE :> es - , Store :> es - , Error StoreError :> es - , KirokuStoreResource :> es - , BoolAlg phi (RegFile rs, ci) - , BoolAlg targetPhi (RegFile targetRs, targetCi) - , Eq co - , Eq targetCo - ) => - WorkerOptions es msg -> - RunCommandOptions -> - ProcessManager input phi rs s ci co targetPhi targetRs targetState targetCi targetCo -> - Adapter es msg -> - (msg -> Maybe (RecordedEvent, input)) -> - Eff es () -runProcessManagerWorkerWith workerOptions options manager Adapter{source = adapterSource} decodeMessage = - Streamly.fold Fold.drain - $ Streamly.mapM handleIngested adapterSource - where - handleIngested :: Ingested es msg -> Eff es AckDecision - handleIngested Ingested{envelope = env@Envelope{payload = message}, ack = AckHandle finalizeAck} = do - decision <- case decodeMessage message of - Nothing -> decideForPoison workerOptions "process-manager worker could not decode message" env - Just (recorded, input) -> do - let correlationId = (manager ^. #correlate) input - managerStream = (manager ^. #streamFor) correlationId - managerStreamName = ((unvalidated (manager ^. #eventStream)) ^. #resolveStreamName) managerStream - attemptCount = envelopeAttemptCount env - outcome <- tryError @StoreError (runProcessManagerOnce options manager recorded input) - case outcome of - Left (_, storeErr) -> do - recordDispatchFailed (workerOptions ^. #metrics) 1 - pure (ackForThrownStoreError (workerOptions ^. #transientRetryDelay) storeErr) - Right (Left err) -> do - recordDispatchFailed (workerOptions ^. #metrics) 1 - decideForFailures - workerOptions - DispatcherProcessManager - (manager ^. #name) - correlationId - recorded - attemptCount - [DispatchFailure (-1) managerStreamName err] - Right (Right result) -> - ackForResults - workerOptions - (manager ^. #name) - correlationId - recorded - attemptCount - (result ^. #managerResult) - (result ^. #commandResults) - finalizeAck decision - pure decision - -ackForThrownStoreError :: RetryDelay -> StoreError -> AckDecision -ackForThrownStoreError delay = ackForCommandError delay . StoreFailed - -ackForResults :: - (IOE :> es, Store :> es) => - WorkerOptions es msg -> - Text -> - Text -> - RecordedEvent -> - Int -> - PMStateResult managerTarget -> - [PMCommandResult commandTarget] -> - Eff es AckDecision -ackForResults workerOptions managerName correlationId sourceEvent attemptCount managerResult commandResults = do - let duplicateCount = stateDuplicateCount managerResult + commandDuplicateCount commandResults - failures = - [ DispatchFailure emitIndex targetStreamName err - | (emitIndex, PMCommandFailed targetStreamName err) <- zip [0 ..] commandResults - ] - recordDispatchDuplicate (workerOptions ^. #metrics) duplicateCount - recordDispatchFailed (workerOptions ^. #metrics) (fromIntegral (length failures)) - decideForFailures - workerOptions - DispatcherProcessManager - managerName - correlationId - sourceEvent - attemptCount - failures - -stateDuplicateCount :: PMStateResult target -> Int64 -stateDuplicateCount = \case - PMStateDuplicate{} -> 1 - PMStateAppended{} -> 0 - -commandDuplicateCount :: [PMCommandResult target] -> Int64 -commandDuplicateCount = - fromIntegral . length . filter isDuplicateResult - where - isDuplicateResult = \case - PMCommandDuplicate{} -> True - _ -> False - -envelopeAttemptCount :: Envelope msg -> Int -envelopeAttemptCount env = - case env ^. #attempt of - Nothing -> 1 - Just (Attempt attempt) -> fromIntegral attempt + 1 - -decideForPoison :: - (IOE :> es) => - WorkerOptions es msg -> - Text -> - Envelope msg -> - Eff es AckDecision -decideForPoison workerOptions reason env = do - recordDispatchPoison (workerOptions ^. #metrics) 1 - case workerOptions ^. #poisonPolicy of - PoisonHalt -> pure (AckHalt (HaltFatal reason)) - PoisonSkip callback -> do - callback env - pure AckOk - PoisonDeadLetter callback -> do - callback env - pure (AckDeadLetter (InvalidPayload reason)) - -eventIdToUuid :: EventId -> UUID.UUID -eventIdToUuid (EventId uuid) = uuid - -{- | Check whether an event with the given id is already present in a live stream. -Used as the pre-dispatch idempotency guard so a -command that was already applied on a prior (possibly crashed) attempt is -recognized as a duplicate before re-running it. --} -eventAlreadyIn :: - (Store :> es) => - RunCommandOptions -> - StoreTypes.StreamName -> - EventId -> - Eff es Bool -eventAlreadyIn _options streamName eventId = - eventExistsInStream streamName eventId - -{- | Decide whether a failed append is a benign duplicate of the write just -attempted: whether @ourId@ is genuinely present in @streamName@. - -Kiroku's @DuplicateEvent@ carries 'Just' the colliding id only when -PostgreSQL's detail string parses ('Nothing' otherwise), and because the -store's event-id uniqueness is global, even a matching id does not prove the -event landed in our stream. A mismatched id is never ours; a matching or -missing id is confirmed against the target stream with a point lookup. Callers -fold 'True' into their duplicate result and surface 'False' as the original -failure. --} -confirmBenignDuplicate :: - (Store :> es) => - StoreTypes.StreamName -> - EventId -> - CommandError -> - Eff es Bool -confirmBenignDuplicate streamName ourId = \case - StoreFailed (DuplicateEvent (Just duplicateId)) - | duplicateId == ourId -> eventExistsInStream streamName ourId - StoreFailed (DuplicateEvent Nothing) -> eventExistsInStream streamName ourId - _ -> pure False +-- | Stateful coordination across aggregates: the process manager (saga). +-- +-- A 'ProcessManager' reacts to an incoming event by stepping its /own/ state +-- machine — a private \"manager\" event stream, keyed by a correlation id — and, +-- in the same turn, dispatching commands to /target/ aggregates and scheduling +-- timers. It is the stateful counterpart of "Keiro.Router": where a router +-- resolves targets from a read model and holds no state, a process manager +-- folds the events it has seen into durable manager state and decides what to +-- do next from that state. +-- +-- Every write — the manager-state append, each dispatched command, each timer +-- — is keyed by a 'deterministicCommandId' derived from +-- @(name, correlation, source event id, emit index)@. The manager pre-checks +-- each id with 'eventAlreadyIn' and folds the store's duplicate rejection into +-- a benign 'PMCommandDuplicate' \/ 'PMStateDuplicate'. Replaying the same +-- source event therefore appends nothing new, which is what makes the worker +-- crash-safe under at-least-once delivery. +-- +-- Use 'runProcessManagerOnce' to react to a single event, or +-- 'runProcessManagerWorker' to run the manager as a live subscription over a +-- Shibuya adapter. Worker acks are finalized exactly once: successful and duplicate +-- dispatches ack 'AckOk', transient store failures retry, systemic deterministic +-- failures halt, rejection-class failures follow 'RejectedCommandPolicy', and +-- undecodable messages follow the configured 'PoisonPolicy'. +-- +-- === Rejected commands and saga history +-- +-- 'RejectedHalt' is the safe default: the subscription stops without advancing, +-- so an operator cannot miss the failure. 'RejectedDeadLetter' instead writes a +-- durable "Keiro.DeadLetter.DispatchDeadLetter" and acknowledges the source +-- event; 'RejectedSkip' acknowledges and records only the metric. Prefer making a +-- target command total in its Keiki transducer (for example, an explicit no-op +-- transition for a benign business rejection) so no policy escape hatch is +-- needed. +-- +-- For a process manager, dead-lettering a target dispatch creates an important +-- history split: the manager's own state stream has recorded its reaction, but +-- the target command never applied. Keiro cannot append a generic correction to +-- the manager stream because an event unknown to the manager's transducer would +-- make that stream fail replay. If saga history must reflect the failure, model a +-- domain-specific @DispatchFailed@-style command and event in the manager and +-- drive it from 'Keiro.DeadLetter.listDispatchDeadLetters' through an operator +-- runbook or automation. Otherwise, the dead-letter row is the durable witness. +-- Manager-state rejection itself has no such split because no manager event was +-- appended; its record uses emit index @-1@. +-- +-- === Bounded retries and source-event dead letters +-- +-- On a Kiroku-backed Shibuya adapter, a transient failure finalizes 'AckRetry', +-- but retries are bounded by the Kiroku subscription's @RetryPolicy@. Its +-- @retryMaxAttempts@ counts total deliveries and defaults to five. When the bound +-- is exhausted, Kiroku records the /source event/ in @kiroku.dead_letters@ with +-- structured reason kind @max_attempts_exceeded@ and atomically advances the +-- checkpoint. The manager will not see that event again unless an operator +-- replays it through @Keiro.DeadLetter.Replay@. Install +-- 'Keiro.Telemetry.kirokuEventBridge' on Kiroku's @eventHandler@ to observe the +-- terminal transition. +-- +-- The adapter's @KirokuAdapterConfig@ does not currently expose @retryPolicy@, so +-- that path uses Kiroku's default bound. The sharded path is configurable: +-- 'Keiro.Subscription.Shard.Worker.runShardedSubscriptionGroupAck' forwards +-- 'Keiro.Subscription.Shard.Worker.ShardedWorkerOptions.retryPolicy' into the +-- same Kiroku acknowledgement ladder. A shard handler that dispatches commands +-- can use 'decideForFailures' and 'isRejectionClass' to classify outcomes, then +-- map the decision to its existing @ShardAck@ reply. +-- +-- === Correlation, ordering, and transaction boundaries +-- +-- Events from one originating stream retain that stream's append order. Kiroku +-- consumer groups hash the originating stream id to a stable member, so sharding +-- does not split one stream across readers. Events from /different/ streams that +-- 'correlate' to the same manager instance have no business-order guarantee, +-- however. Their append transactions race for global positions and, under +-- sharding, the streams may be processed concurrently by different members. A +-- retry on one member does not stop another member from advancing. +-- +-- For example, both @payment-ORD1@'s @PaymentCaptured@ and @shipment-ORD1@'s +-- @ShipmentAllocated@ may correlate to order @ORD1@. The manager must accept +-- @PaymentCaptured@ then @ShipmentAllocated@ /and/ the reverse, normally with +-- states that record one fact while waiting for the other. An unsharded Kiroku +-- subscription processes its observed global order serially, including retries, +-- but that order still reflects append timing rather than a domain sequence. +-- +-- Rule of thumb: 'correlate' may join streams freely, but every such join must be +-- order-insensitive. When a strict sequence is required, enforce it in the +-- manager's own state machine — for example with an explicit no-op/waiting state +-- and a timer-driven retry, or a modeled rejection handled by the dead-letter +-- policy — never by assuming delivery order. +-- +-- The persistence boundary is also intentionally smaller than one whole saga +-- reaction. A manager event and its timers commit together when the manager +-- command appends; a timer-only no-op reaction schedules its timers in a separate +-- transaction. Each target command and its inline projections then commit in +-- their own transaction. A crash or rejected target can therefore leave durable +-- manager history without every target write. Deterministic ids make source-event +-- replay fill the missing writes without duplicating completed ones; the rejected +-- command section above describes the case that is deliberately acknowledged +-- instead. +module Keiro.ProcessManager + ( -- * Definition + ProcessManager (..), + ProcessManagerAction (..), + PMCommand (..), + + -- * Results + ProcessManagerResult (..), + PMCommandResult (..), + PMStateResult (..), + + -- * Running + PoisonPolicy (..), + RejectedCommandPolicy (..), + DispatchFailure (..), + WorkerOptions (..), + defaultWorkerOptions, + isTransientStoreError, + isTransientCommandError, + isRejectionClass, + decideForFailures, + ackForCommandError, + runProcessManagerOnce, + runProcessManagerWorkerWith, + runProcessManagerWorker, + + -- * Idempotency primitives + deterministicCommandId, + eventAlreadyIn, + confirmBenignDuplicate, + ) +where + +import Data.Coerce (coerce) +import Data.Text qualified as Text +import Data.UUID qualified as UUID +import Data.UUID.V5 qualified as UUID.V5 +import Effectful (Eff, IOE, (:>)) +import Effectful.Error.Static (Error, tryError) +import GHC.Stack (HasCallStack) +import Keiki.Core (BoolAlg, RegFile) +import Keiro.Command (CommandError (..), CommandResult, RunCommandOptions, commandErrorClass, runCommandWithSql) +import Keiro.DeadLetter (DispatchDeadLetter (..), DispatcherKind (..), recordDispatchDeadLetter) +import Keiro.EventStream (EventStream) +import Keiro.EventStream.Validate (ValidatedEventStream, unvalidated) +import Keiro.Prelude +import Keiro.Projection (InlineProjection, runCommandWithProjections) +import Keiro.Stream (Stream) +import Keiro.Telemetry (KeiroMetrics, recordDispatchDeadLettered, recordDispatchDuplicate, recordDispatchFailed, recordDispatchPoison) +import Keiro.Timer (TimerRequest, scheduleTimerTx) +import Kiroku.Store.Effect (Store) +import Kiroku.Store.Effect.Resource (KirokuStoreResource) +import Kiroku.Store.Error (StoreError (..)) +import Kiroku.Store.Read (eventExistsInStream) +import Kiroku.Store.Transaction (runTransaction) +import Kiroku.Store.Types (EventId (..), RecordedEvent) +import Kiroku.Store.Types qualified as StoreTypes +import Shibuya.Adapter (Adapter (..)) +import Shibuya.Core.Ack (AckDecision (..), DeadLetterReason (..), HaltReason (..), RetryDelay (..)) +import Shibuya.Core.AckHandle (AckHandle (..)) +import Shibuya.Core.Ingested (Ingested (..)) +import Shibuya.Core.Types (Attempt (..), Envelope (..)) +import Streamly.Data.Fold qualified as Fold +import Streamly.Data.Stream qualified as Streamly +import Prelude (any, filter, fromIntegral, length, not, uncurry, zip, (&&), (+)) + +-- | A process manager wiring together a manager state machine and the target +-- aggregate it drives. +-- +-- * 'name' — stable identity; part of every deterministic write id. +-- * 'correlate' — derives the correlation key for an input event, selecting +-- which manager instance handles it. +-- * 'eventStream' — the manager's own 'EventStream'; its events record the +-- saga's progress. +-- * 'streamFor' — maps a correlation key to the manager's 'Stream' handle. +-- * 'targetEventStream' — the aggregate that dispatched commands are sent to. +-- * 'targetProjections' — inline projections for the target aggregate, run in +-- the same transaction as each dispatched command's append. Return @[]@ for +-- append-only dispatch. +-- * 'handle' — the pure reaction: given an input event, produce the +-- manager-state command, the target commands to dispatch, and any timers to +-- schedule. +data ProcessManager input phi rs s ci co targetPhi targetRs targetState targetCi targetCo = ProcessManager + { name :: !Text, + correlate :: !(input -> Text), + eventStream :: !(ValidatedEventStream phi rs s ci co), + streamFor :: !(Text -> Stream (EventStream phi rs s ci co)), + targetEventStream :: !(ValidatedEventStream targetPhi targetRs targetState targetCi targetCo), + -- | Inline projections for the target aggregate, run in the same transaction + -- as each dispatched command's append. Return @[]@ for append-only dispatch. + targetProjections :: !(Stream targetCi -> [InlineProjection targetCo]), + handle :: !(input -> ProcessManagerAction ci targetCi) + } + deriving stock (Generic) + +-- | What a process manager decides to do for one input event: advance its own +-- state with 'command', dispatch zero or more target 'commands', and schedule +-- zero or more 'timers'. All three are applied atomically with crash-safe +-- idempotency by 'runProcessManagerOnce'. +data ProcessManagerAction ci targetCi = ProcessManagerAction + { command :: !ci, + commands :: ![PMCommand targetCi], + timers :: ![TimerRequest] + } + deriving stock (Generic) + +-- | A single command addressed to a specific target stream. +data PMCommand targetCi = PMCommand + { target :: !(Stream targetCi), + command :: !targetCi + } + deriving stock (Generic, Eq, Show) + +-- | Outcome of one dispatched target command. +data PMCommandResult target + = -- | The command appended events (carries the 'CommandResult'). + PMCommandAppended !(CommandResult target) + | -- | The command was already applied (idempotent replay); carries the + -- deterministic id that already existed. + PMCommandDuplicate !EventId + | -- | The command failed in the named target stream; the worker classifies + -- the error. Transient failures retry, rejection-class failures follow + -- 'RejectedCommandPolicy', and systemic deterministic failures halt. + PMCommandFailed !StoreTypes.StreamName !CommandError + deriving stock (Generic, Eq, Show) + +-- | Outcome of the manager's own state append. Unlike 'PMCommandResult' there +-- is no failure case — a manager-state append that genuinely errors aborts the +-- whole reaction via an outer @Left@ 'CommandError'. +data PMStateResult target + = PMStateAppended !(CommandResult target) + | PMStateDuplicate !EventId + deriving stock (Generic, Eq, Show) + +-- | The complete result of reacting to one event: how the manager state +-- advanced, the outcome of each dispatched command in order, and how many +-- timers were scheduled. +data ProcessManagerResult managerTarget commandTarget = ProcessManagerResult + { managerResult :: !(PMStateResult managerTarget), + commandResults :: ![PMCommandResult commandTarget], + timersScheduled :: !Int + } + deriving stock (Generic, Eq, Show) + +-- | What a worker does with a message its decoder cannot parse. +data PoisonPolicy es msg + = PoisonHalt + | PoisonSkip !(Envelope msg -> Eff es ()) + | PoisonDeadLetter !(Envelope msg -> Eff es ()) + +-- | What a worker does when every failed dispatch is a rejection-class error. +data RejectedCommandPolicy + = -- | Halt without acknowledging so the source event replays. This is the default. + RejectedHalt + | -- | Persist a durable dispatch dead letter and acknowledge the source event. + RejectedDeadLetter + | -- | Acknowledge and count the rejection without persisting a record. + RejectedSkip + deriving stock (Generic, Eq, Show) + +-- | One failed dispatch with the target identity needed by worker policy. +data DispatchFailure = DispatchFailure + { emitIndex :: !Int, + targetStreamName :: !StoreTypes.StreamName, + commandError :: !CommandError + } + deriving stock (Generic, Eq, Show) + +-- | Worker-level knobs shared by the process-manager and router workers. +data WorkerOptions es msg = WorkerOptions + { poisonPolicy :: !(PoisonPolicy es msg), + rejectedCommandPolicy :: !RejectedCommandPolicy, + transientRetryDelay :: !RetryDelay, + metrics :: !(Maybe KeiroMetrics) + } + deriving stock (Generic) + +defaultWorkerOptions :: WorkerOptions es msg +defaultWorkerOptions = + WorkerOptions + { poisonPolicy = PoisonHalt, + rejectedCommandPolicy = RejectedHalt, + transientRetryDelay = RetryDelay 5, + metrics = Nothing + } + +isTransientStoreError :: StoreError -> Bool +isTransientStoreError = \case + ConnectionLost {} -> True + PoolAcquisitionTimeout -> True + ConnectionError {} -> True + WrongExpectedVersion {} -> True + StreamAlreadyExists {} -> True + EmptyAppendBatch {} -> False + StreamNotFound {} -> False + ReservedStreamName {} -> False + StreamNameTooLong {} -> False + DuplicateEvent {} -> False + EventAlreadyLinked {} -> False + LinkSourceEventMissing {} -> False + UnexpectedServerError {} -> False + +isTransientCommandError :: CommandError -> Bool +isTransientCommandError = \case + StoreFailed err -> isTransientStoreError err + RetryExhausted _ err -> isTransientStoreError err + ConflictFixpoint _ err -> isTransientStoreError err + HydrationDecodeFailed {} -> False + HydrationReplayFailed {} -> False + HydrationGapDetected {} -> False + CommandRejected -> False + CommandAmbiguous {} -> False + EncodeFailed {} -> False + +-- | Whether a command error is a per-command rejection covered by worker policy. +isRejectionClass :: CommandError -> Bool +isRejectionClass = \case + CommandRejected -> True + CommandAmbiguous {} -> True + _ -> False + +-- | Classify a group of failed dispatches and choose one acknowledgement. +-- +-- Systemic deterministic errors always halt. Any transient error retries the +-- whole source event. Only an all-rejection group reaches the configured +-- 'RejectedCommandPolicy'. Dead-letter writes are idempotent under redelivery. +decideForFailures :: + (IOE :> es, Store :> es) => + WorkerOptions es msg -> + DispatcherKind -> + Text -> + Text -> + RecordedEvent -> + Int -> + [DispatchFailure] -> + Eff es AckDecision +decideForFailures workerOptions dispatcherKind dispatcherName correlationId sourceEvent attemptCount failures = + case filter isSystemicDeterministic failures of + failure : _ -> pure (haltFor failure) + [] + | any (isTransientCommandError . (^. #commandError)) failures -> + pure (AckRetry (workerOptions ^. #transientRetryDelay)) + | otherwise -> + case failures of + [] -> pure AckOk + _ -> decideRejected + where + isSystemicDeterministic failure = + let err = failure ^. #commandError + in not (isTransientCommandError err) && not (isRejectionClass err) + + haltFor failure = + AckHalt (HaltFatal (Text.pack (show (failure ^. #commandError)))) + + decideRejected = + case workerOptions ^. #rejectedCommandPolicy of + RejectedHalt -> pure (haltFor (headFailure failures)) + RejectedDeadLetter -> do + traverse_ recordFailure failures + recordHandled + pure AckOk + RejectedSkip -> do + recordHandled + pure AckOk + + recordHandled = + recordDispatchDeadLettered + (workerOptions ^. #metrics) + (fromIntegral (length failures)) + + recordFailure failure = + let err = failure ^. #commandError + in recordDispatchDeadLetter + DispatchDeadLetter + { dispatcherKind = dispatcherKind, + dispatcherName = dispatcherName, + correlationId = correlationId, + sourceEventId = sourceEvent ^. #eventId, + sourceGlobalPosition = sourceEvent ^. #globalPosition, + emitIndex = failure ^. #emitIndex, + targetStreamName = failure ^. #targetStreamName, + errorClass = commandErrorClass err, + errorDetail = Text.pack (show err), + attemptCount = max 1 attemptCount + } + + headFailure = \case + failure : _ -> failure + [] -> DispatchFailure (-1) (StoreTypes.StreamName "unknown") CommandRejected + +ackForCommandError :: RetryDelay -> CommandError -> AckDecision +ackForCommandError delay err + | isTransientCommandError err = AckRetry delay + | otherwise = AckHalt (HaltFatal (Text.pack (show err))) + +-- | Derive a stable, collision-resistant 'EventId' for a manager write from +-- @(manager name, correlation id, source event id, emit index)@ via a v5 UUID. +-- +-- The same inputs always yield the same id, so a replayed source event +-- produces the same write ids and the store's uniqueness constraint collapses +-- the duplicate. The manager-state append uses an emit index of @-1@ to keep +-- it distinct from the dispatched commands (which start at @0@). This positional +-- index is sound because 'handle' is pure and therefore returns the same command +-- order for the same input. The effectful router uses +-- 'Keiro.Router.deterministicRouterCommandId' instead, retaining this positional +-- id only as a transition probe for pre-upgrade router dispatches. +deterministicCommandId :: Text -> Text -> EventId -> Int -> EventId +deterministicCommandId managerName correlationId sourceEventId emitIndex = + EventId + $ UUID.V5.generateNamed UUID.V5.namespaceURL + $ fmap (fromIntegral . fromEnum) + $ Text.unpack + $ Text.intercalate + ":" + [ "keiro", + "process-manager", + managerName, + correlationId, + UUID.toText (eventIdToUuid sourceEventId), + Text.pack (show emitIndex) + ] + +-- | React to a single source event: advance the manager's state, dispatch +-- its target commands, and schedule its timers — each under a deterministic, +-- idempotent write id. +-- +-- The manager-state append and its timers commit in one transaction; each +-- target command is then dispatched (with its inline projections) in its own. +-- A duplicate manager append short-circuits to 'PMStateDuplicate' but still +-- re-runs the dispatch loop, so a crash between the state append and a +-- command dispatch is recovered on replay. Returns @Left@ only when the +-- manager-state append fails for a non-duplicate reason; per-command failures +-- are reported inside 'commandResults'. +runProcessManagerOnce :: + forall input phi rs s ci co targetPhi targetRs targetState targetCi targetCo es. + ( HasCallStack, + IOE :> es, + Store :> es, + Error StoreError :> es, + KirokuStoreResource :> es, + BoolAlg phi (RegFile rs, ci), + BoolAlg targetPhi (RegFile targetRs, targetCi), + Eq co, + Eq targetCo + ) => + RunCommandOptions -> + ProcessManager input phi rs s ci co targetPhi targetRs targetState targetCi targetCo -> + RecordedEvent -> + input -> + Eff es (Either CommandError (ProcessManagerResult (EventStream phi rs s ci co) (EventStream targetPhi targetRs targetState targetCi targetCo))) +runProcessManagerOnce options manager sourceEvent input = do + let correlationId = (manager ^. #correlate) input + action = (manager ^. #handle) input + managerStream = (manager ^. #streamFor) correlationId + managerEventId = deterministicCommandId (manager ^. #name) correlationId (sourceEvent ^. #eventId) (-1) + managerOptions = options & #eventIds .~ [managerEventId] + managerStreamName = ((unvalidated (manager ^. #eventStream)) ^. #resolveStreamName) managerStream + managerAlreadyProcessed <- eventAlreadyIn options managerStreamName managerEventId + if managerAlreadyProcessed + then finish correlationId (PMStateDuplicate managerEventId) action + else do + managerOutcome <- + runCommandWithSql + managerOptions + (manager ^. #eventStream) + managerStream + (action ^. #command) + (\_ -> traverse_ scheduleTimerTx (action ^. #timers)) + case managerOutcome of + Left err -> do + benign <- confirmBenignDuplicate managerStreamName managerEventId err + if benign + then finish correlationId (PMStateDuplicate managerEventId) action + else pure (Left err) + Right (managerResult, scheduledInAppend) -> do + -- No-op manager commands do not execute runCommandWithSql's callback, + -- so schedule timer-only reactions explicitly. + case scheduledInAppend of + Nothing -> runTransaction (traverse_ scheduleTimerTx (action ^. #timers)) + Just () -> pure () + finish correlationId (PMStateAppended managerResult) action + where + finish correlationId managerResult action = do + commandResults <- dispatchCommands correlationId (sourceEvent ^. #eventId) (action ^. #commands) + pure + $ Right + ProcessManagerResult + { managerResult = managerResult, + commandResults = commandResults, + timersScheduled = length (action ^. #timers) + } + + dispatchCommands correlationId sourceEventId commands = + traverse + (uncurry (dispatchCommand correlationId sourceEventId)) + (zip [0 ..] commands) + + dispatchCommand correlationId sourceEventId emitIndex command = do + let commandId = deterministicCommandId (manager ^. #name) correlationId sourceEventId emitIndex + targetOptions = options & #eventIds .~ [commandId] + targetStream = retarget (command ^. #target) + targetStreamName = ((unvalidated (manager ^. #targetEventStream)) ^. #resolveStreamName) targetStream + commandAlreadyProcessed <- eventAlreadyIn options targetStreamName commandId + if commandAlreadyProcessed + then pure (PMCommandDuplicate commandId) + else do + outcome <- + runCommandWithProjections + targetOptions + (manager ^. #targetEventStream) + targetStream + (command ^. #command) + ((manager ^. #targetProjections) (command ^. #target)) + case outcome of + Right result -> pure (PMCommandAppended result) + Left err -> do + benign <- confirmBenignDuplicate targetStreamName commandId err + pure $ if benign then PMCommandDuplicate commandId else PMCommandFailed targetStreamName err + + retarget :: Stream targetCi -> Stream (EventStream targetPhi targetRs targetState targetCi targetCo) + retarget = coerce + +-- | Run a process manager as a live subscription draining a Shibuya adapter with +-- 'defaultWorkerOptions'. +-- +-- Use 'runProcessManagerWorkerWith' to override poison-message handling, rejected +-- command handling, transient retry delay, or dispatch metrics. Every ingested message's ack handle is +-- finalized exactly once. Successful and duplicate dispatches finalize 'AckOk'; +-- transient store failures finalize 'AckRetry'; rejection-class failures follow +-- 'RejectedCommandPolicy'; other deterministic failures finalize 'AckHalt'; +-- undecodable messages follow the configured 'PoisonPolicy'. Under +-- 'RejectedDeadLetter', see the module-level saga-history contract before opting +-- in. On a Kiroku-backed adapter, each 'AckRetry' redelivery is bounded by the +-- subscription @RetryPolicy@ (five total deliveries by default). Exhaustion +-- dead-letters the source event in @kiroku.dead_letters@ and advances the +-- checkpoint; @KirokuAdapterConfig@ does not currently expose that bound. Observe +-- the terminal event with 'Keiro.Telemetry.kirokuEventBridge' and replay it with +-- @Keiro.DeadLetter.Replay@ when appropriate. +runProcessManagerWorker :: + forall msg input phi rs s ci co targetPhi targetRs targetState targetCi targetCo es. + ( HasCallStack, + IOE :> es, + Store :> es, + Error StoreError :> es, + KirokuStoreResource :> es, + BoolAlg phi (RegFile rs, ci), + BoolAlg targetPhi (RegFile targetRs, targetCi), + Eq co, + Eq targetCo + ) => + RunCommandOptions -> + ProcessManager input phi rs s ci co targetPhi targetRs targetState targetCi targetCo -> + Adapter es msg -> + (msg -> Maybe (RecordedEvent, input)) -> + Eff es () +runProcessManagerWorker = + runProcessManagerWorkerWith defaultWorkerOptions + +runProcessManagerWorkerWith :: + forall msg input phi rs s ci co targetPhi targetRs targetState targetCi targetCo es. + ( HasCallStack, + IOE :> es, + Store :> es, + Error StoreError :> es, + KirokuStoreResource :> es, + BoolAlg phi (RegFile rs, ci), + BoolAlg targetPhi (RegFile targetRs, targetCi), + Eq co, + Eq targetCo + ) => + WorkerOptions es msg -> + RunCommandOptions -> + ProcessManager input phi rs s ci co targetPhi targetRs targetState targetCi targetCo -> + Adapter es msg -> + (msg -> Maybe (RecordedEvent, input)) -> + Eff es () +runProcessManagerWorkerWith workerOptions options manager Adapter {source = adapterSource} decodeMessage = + Streamly.fold Fold.drain + $ Streamly.mapM handleIngested adapterSource + where + handleIngested :: Ingested es msg -> Eff es AckDecision + handleIngested Ingested {envelope = env@Envelope {payload = message}, ack = AckHandle finalizeAck} = do + decision <- case decodeMessage message of + Nothing -> decideForPoison workerOptions "process-manager worker could not decode message" env + Just (recorded, input) -> do + let correlationId = (manager ^. #correlate) input + managerStream = (manager ^. #streamFor) correlationId + managerStreamName = ((unvalidated (manager ^. #eventStream)) ^. #resolveStreamName) managerStream + attemptCount = envelopeAttemptCount env + outcome <- tryError @StoreError (runProcessManagerOnce options manager recorded input) + case outcome of + Left (_, storeErr) -> do + recordDispatchFailed (workerOptions ^. #metrics) 1 + pure (ackForThrownStoreError (workerOptions ^. #transientRetryDelay) storeErr) + Right (Left err) -> do + recordDispatchFailed (workerOptions ^. #metrics) 1 + decideForFailures + workerOptions + DispatcherProcessManager + (manager ^. #name) + correlationId + recorded + attemptCount + [DispatchFailure (-1) managerStreamName err] + Right (Right result) -> + ackForResults + workerOptions + (manager ^. #name) + correlationId + recorded + attemptCount + (result ^. #managerResult) + (result ^. #commandResults) + finalizeAck decision + pure decision + +ackForThrownStoreError :: RetryDelay -> StoreError -> AckDecision +ackForThrownStoreError delay = ackForCommandError delay . StoreFailed + +ackForResults :: + (IOE :> es, Store :> es) => + WorkerOptions es msg -> + Text -> + Text -> + RecordedEvent -> + Int -> + PMStateResult managerTarget -> + [PMCommandResult commandTarget] -> + Eff es AckDecision +ackForResults workerOptions managerName correlationId sourceEvent attemptCount managerResult commandResults = do + let duplicateCount = stateDuplicateCount managerResult + commandDuplicateCount commandResults + failures = + [ DispatchFailure emitIndex targetStreamName err + | (emitIndex, PMCommandFailed targetStreamName err) <- zip [0 ..] commandResults + ] + recordDispatchDuplicate (workerOptions ^. #metrics) duplicateCount + recordDispatchFailed (workerOptions ^. #metrics) (fromIntegral (length failures)) + decideForFailures + workerOptions + DispatcherProcessManager + managerName + correlationId + sourceEvent + attemptCount + failures + +stateDuplicateCount :: PMStateResult target -> Int64 +stateDuplicateCount = \case + PMStateDuplicate {} -> 1 + PMStateAppended {} -> 0 + +commandDuplicateCount :: [PMCommandResult target] -> Int64 +commandDuplicateCount = + fromIntegral . length . filter isDuplicateResult + where + isDuplicateResult = \case + PMCommandDuplicate {} -> True + _ -> False + +envelopeAttemptCount :: Envelope msg -> Int +envelopeAttemptCount env = + case env ^. #attempt of + Nothing -> 1 + Just (Attempt attempt) -> fromIntegral attempt + 1 + +decideForPoison :: + (IOE :> es) => + WorkerOptions es msg -> + Text -> + Envelope msg -> + Eff es AckDecision +decideForPoison workerOptions reason env = do + recordDispatchPoison (workerOptions ^. #metrics) 1 + case workerOptions ^. #poisonPolicy of + PoisonHalt -> pure (AckHalt (HaltFatal reason)) + PoisonSkip callback -> do + callback env + pure AckOk + PoisonDeadLetter callback -> do + callback env + pure (AckDeadLetter (InvalidPayload reason)) + +eventIdToUuid :: EventId -> UUID.UUID +eventIdToUuid (EventId uuid) = uuid + +-- | Check whether an event with the given id is already present in a live stream. +-- Used as the pre-dispatch idempotency guard so a +-- command that was already applied on a prior (possibly crashed) attempt is +-- recognized as a duplicate before re-running it. +eventAlreadyIn :: + (Store :> es) => + RunCommandOptions -> + StoreTypes.StreamName -> + EventId -> + Eff es Bool +eventAlreadyIn _options streamName eventId = + eventExistsInStream streamName eventId + +-- | Decide whether a failed append is a benign duplicate of the write just +-- attempted: whether @ourId@ is genuinely present in @streamName@. +-- +-- Kiroku's @DuplicateEvent@ carries 'Just' the colliding id only when +-- PostgreSQL's detail string parses ('Nothing' otherwise), and because the +-- store's event-id uniqueness is global, even a matching id does not prove the +-- event landed in our stream. A mismatched id is never ours; a matching or +-- missing id is confirmed against the target stream with a point lookup. Callers +-- fold 'True' into their duplicate result and surface 'False' as the original +-- failure. +confirmBenignDuplicate :: + (Store :> es) => + StoreTypes.StreamName -> + EventId -> + CommandError -> + Eff es Bool +confirmBenignDuplicate streamName ourId = \case + StoreFailed (DuplicateEvent (Just duplicateId)) + | duplicateId == ourId -> eventExistsInStream streamName ourId + StoreFailed (DuplicateEvent Nothing) -> eventExistsInStream streamName ourId + _ -> pure False diff --git a/src/Keiro/Projection.hs b/src/Keiro/Projection.hs --- a/src/Keiro/Projection.hs +++ b/src/Keiro/Projection.hs @@ -1,24 +1,23 @@ -{- | Projections: turning a stream's events into read-side state. - -Two flavors, trading consistency against coupling: - -* An 'InlineProjection' runs in the /same/ transaction as the command that - produced the events, so the read model is updated atomically with the - append — never stale, but tied to the writer's transaction and latency. - 'runCommandWithProjections' runs a command and applies a list of inline - projections to whatever it emits. -* An 'AsyncProjection' runs later from a subscription draining the event - log. It carries a 'subscriptionName' for checkpointing and an - 'idempotencyKey' so redelivery is safe; 'applyAsyncProjection' performs - one application. This decouples the read model from the writer at the - cost of eventual consistency. - -Both ultimately fold events into a SQL read model via a -'Hasql.Transaction.Transaction'; the difference is only /when/ that -transaction runs. --} -module Keiro.Projection ( - -- * Inline projections +-- | Projections: turning a stream's events into read-side state. +-- +-- Two flavors, trading consistency against coupling: +-- +-- * An 'InlineProjection' runs in the /same/ transaction as the command that +-- produced the events, so the read model is updated atomically with the +-- append — never stale, but tied to the writer's transaction and latency. +-- 'runCommandWithProjections' runs a command and applies a list of inline +-- projections to whatever it emits. +-- * An 'AsyncProjection' runs later from a subscription draining the event +-- log. It carries a 'subscriptionName' for checkpointing and an +-- 'idempotencyKey' so redelivery is safe; 'applyAsyncProjection' performs +-- one application. This decouples the read model from the writer at the +-- cost of eventual consistency. +-- +-- Both ultimately fold events into a SQL read model via a +-- 'Hasql.Transaction.Transaction'; the difference is only /when/ that +-- transaction runs. +module Keiro.Projection + ( -- * Inline projections InlineProjection (..), runCommandWithProjections, @@ -29,7 +28,7 @@ applyAsyncProjectionUnfenced, pruneAsyncProjectionDedupBefore, recordProjectionLag, -) + ) where import Contravariant.Extras (contrazip2) @@ -57,154 +56,147 @@ import "hasql-transaction" Hasql.Transaction qualified as Tx import Prelude qualified -{- | A read-model update applied synchronously with the command that emits -the event. 'apply' receives both the decoded event @co@ and the -'RecordedEvent' the store persisted, and runs in the append transaction. -'name' identifies the projection for diagnostics. --} +-- | A read-model update applied synchronously with the command that emits +-- the event. 'apply' receives both the decoded event @co@ and the +-- 'RecordedEvent' the store persisted, and runs in the append transaction. +-- 'name' identifies the projection for diagnostics. data InlineProjection co = InlineProjection - { name :: !Text - , apply :: !(co -> RecordedEvent -> Tx.Transaction ()) - } - deriving stock (Generic) - -{- | A read-model update applied asynchronously by a subscription worker. + { name :: !Text, + apply :: !(co -> RecordedEvent -> Tx.Transaction ()) + } + deriving stock (Generic) -* 'name' — identifies the projection for diagnostics. -* 'readModelName' — names the registry row for the model this projection writes. -* 'subscriptionName' — the cursor under which the worker checkpoints its - progress through the event log. -* 'applyRecorded' — folds one 'RecordedEvent' into the read model. -* 'idempotencyKey' — the 'EventId' used to suppress duplicate application on - redelivery, making the projection safe to retry. --} +-- | A read-model update applied asynchronously by a subscription worker. +-- +-- * 'name' — identifies the projection for diagnostics. +-- * 'readModelName' — names the registry row for the model this projection writes. +-- * 'subscriptionName' — the cursor under which the worker checkpoints its +-- progress through the event log. +-- * 'applyRecorded' — folds one 'RecordedEvent' into the read model. +-- * 'idempotencyKey' — the 'EventId' used to suppress duplicate application on +-- redelivery, making the projection safe to retry. data AsyncProjection = AsyncProjection - { name :: !Text - , readModelName :: !Text - , subscriptionName :: !Text - , applyRecorded :: !(RecordedEvent -> Tx.Transaction ()) - , idempotencyKey :: !(RecordedEvent -> EventId) - } - deriving stock (Generic) + { name :: !Text, + readModelName :: !Text, + subscriptionName :: !Text, + applyRecorded :: !(RecordedEvent -> Tx.Transaction ()), + idempotencyKey :: !(RecordedEvent -> EventId) + } + deriving stock (Generic) -- | The database-visible result of one asynchronous projection attempt. data AsyncApplyOutcome - = AsyncApplied - | AsyncDuplicate - | AsyncFenced - deriving stock (Generic, Eq, Show) + = AsyncApplied + | AsyncDuplicate + | AsyncFenced + deriving stock (Generic, Eq, Show) -{- | Run a command and apply every supplied 'InlineProjection' to the events -it emits, all inside the command's append transaction. A projection failure -aborts the whole transaction, so the events and the read-model update commit -together or not at all. --} +-- | Run a command and apply every supplied 'InlineProjection' to the events +-- it emits, all inside the command's append transaction. A projection failure +-- aborts the whole transaction, so the events and the read-model update commit +-- together or not at all. runCommandWithProjections :: - forall phi rs s ci co es. - (HasCallStack, IOE :> es, Store :> es, Error StoreError :> es, KirokuStoreResource :> es, BoolAlg phi (RegFile rs, ci), Eq co) => - RunCommandOptions -> - ValidatedEventStream phi rs s ci co -> - Stream (EventStream phi rs s ci co) -> - ci -> - [InlineProjection co] -> - Eff es (Either CommandError (CommandResult (EventStream phi rs s ci co))) + forall phi rs s ci co es. + (HasCallStack, IOE :> es, Store :> es, Error StoreError :> es, KirokuStoreResource :> es, BoolAlg phi (RegFile rs, ci), Eq co) => + RunCommandOptions -> + ValidatedEventStream phi rs s ci co -> + Stream (EventStream phi rs s ci co) -> + ci -> + [InlineProjection co] -> + Eff es (Either CommandError (CommandResult (EventStream phi rs s ci co))) runCommandWithProjections options eventStream targetStream command projections = do - result <- - runCommandWithSqlEvents - options - eventStream - targetStream - command - ( \pairs _appendResult -> + result <- + runCommandWithSqlEvents + options + eventStream + targetStream + command + ( \pairs _appendResult -> + traverse_ + ( \projection -> traverse_ - ( \projection -> - traverse_ - (\(event, recorded) -> (projection ^. #apply) event recorded) - pairs - ) - projections + (\(event, recorded) -> (projection ^. #apply) event recorded) + pairs ) - pure (fmap Prelude.fst result) - -{- | Apply one event to a live 'AsyncProjection', returning a distinct outcome -for a successful application, a retained dedup key, or a rebuild fence. - -The registry row is read with @FOR SHARE@ inside the same transaction as the -dedup insert and application. A missing row or any status other than @live@ -returns 'AsyncFenced' without touching either table. A worker that receives -'AsyncFenced' must not checkpoint past the event: fail or park the delivery and -retry after promotion. Ack-coupled Kiroku delivery preserves the checkpoint -when its handler does not acknowledge success. + projections + ) + pure (fmap Prelude.fst result) -The projection's 'idempotencyKey' is inserted into @keiro_projection_dedup@ -inside the same transaction as 'applyRecorded'. When that insert conflicts, -the event was already applied within the retained dedup window and the update -is skipped. Use 'pruneAsyncProjectionDedupBefore' only for events older than -the subscription system can redeliver; pruning intentionally re-opens those -events for application if they are replayed later. --} +-- | Apply one event to a live 'AsyncProjection', returning a distinct outcome +-- for a successful application, a retained dedup key, or a rebuild fence. +-- +-- The registry row is read with @FOR SHARE@ inside the same transaction as the +-- dedup insert and application. A missing row or any status other than @live@ +-- returns 'AsyncFenced' without touching either table. A worker that receives +-- 'AsyncFenced' must not checkpoint past the event: fail or park the delivery and +-- retry after promotion. Ack-coupled Kiroku delivery preserves the checkpoint +-- when its handler does not acknowledge success. +-- +-- The projection's 'idempotencyKey' is inserted into @keiro_projection_dedup@ +-- inside the same transaction as 'applyRecorded'. When that insert conflicts, +-- the event was already applied within the retained dedup window and the update +-- is skipped. Use 'pruneAsyncProjectionDedupBefore' only for events older than +-- the subscription system can redeliver; pruning intentionally re-opens those +-- events for application if they are replayed later. applyAsyncProjection :: AsyncProjection -> RecordedEvent -> Tx.Transaction AsyncApplyOutcome applyAsyncProjection projection recorded = do - status <- - Tx.statement - (projection ^. #readModelName) - lockReadModelStatusStmt - case status of - Just "live" -> applyAsyncProjectionUnfenced projection recorded - _ -> pure AsyncFenced - -{- | Apply one event without consulting the read-model registry fence. + status <- + Tx.statement + (projection ^. #readModelName) + lockReadModelStatusStmt + case status of + Just "live" -> applyAsyncProjectionUnfenced projection recorded + _ -> pure AsyncFenced -This is exclusively the rebuild replay entry point: it retains normal dedup -semantics while permitting the designated rebuilder to write while the model is -@rebuilding@. Live workers must use 'applyAsyncProjection'. --} +-- | Apply one event without consulting the read-model registry fence. +-- +-- This is exclusively the rebuild replay entry point: it retains normal dedup +-- semantics while permitting the designated rebuilder to write while the model is +-- @rebuilding@. Live workers must use 'applyAsyncProjection'. applyAsyncProjectionUnfenced :: AsyncProjection -> RecordedEvent -> Tx.Transaction AsyncApplyOutcome applyAsyncProjectionUnfenced projection recorded = do - inserted <- - Tx.statement - (projection ^. #name, eventIdToUuid ((projection ^. #idempotencyKey) recorded)) - insertProjectionDedupStmt - if inserted - then do - (projection ^. #applyRecorded) recorded - pure AsyncApplied - else pure AsyncDuplicate - -{- | Age out async-projection dedup rows older than the supplied timestamp. + inserted <- + Tx.statement + (projection ^. #name, eventIdToUuid ((projection ^. #idempotencyKey) recorded)) + insertProjectionDedupStmt + if inserted + then do + (projection ^. #applyRecorded) recorded + pure AsyncApplied + else pure AsyncDuplicate -Use this only beyond the subscription system's redelivery window; pruning -re-opens those events for application. It is not a rebuild reset. Supported -rebuilds use 'Keiro.ReadModel.Rebuild.startRebuild', which atomically deletes -only the named projections' keys while fencing writers and resetting the model. -Returns the number of rows pruned. --} +-- | Age out async-projection dedup rows older than the supplied timestamp. +-- +-- Use this only beyond the subscription system's redelivery window; pruning +-- re-opens those events for application. It is not a rebuild reset. Supported +-- rebuilds use 'Keiro.ReadModel.Rebuild.startRebuild', which atomically deletes +-- only the named projections' keys while fencing writers and resetting the model. +-- Returns the number of rows pruned. pruneAsyncProjectionDedupBefore :: (Store :> es) => UTCTime -> Eff es Int64 pruneAsyncProjectionDedupBefore cutoff = - runTransaction - $ Tx.statement cutoff pruneProjectionDedupBeforeStmt - -{- | Record 'keiro.projection.lag' for one async projection: how many events its -subscription is behind the global log head, computed as the store head global -position minus the subscription's checkpoint position (clamped at 0). A no-op -when no metrics handle is supplied. Call once per drain pass, after applying the -batch, so the gauge reflects the backlog the worker has left to catch up on. + runTransaction + $ Tx.statement cutoff pruneProjectionDedupBeforeStmt -There is no in-library polling drain loop today (the application drives -'applyAsyncProjection' per event), so this is the entry point an application -calls to surface lag for a subscription. --} +-- | Record 'keiro.projection.lag' for one async projection: how many events its +-- subscription is behind the global log head, computed as the store head global +-- position minus the subscription's checkpoint position (clamped at 0). A no-op +-- when no metrics handle is supplied. Call once per drain pass, after applying the +-- batch, so the gauge reflects the backlog the worker has left to catch up on. +-- +-- There is no in-library polling drain loop today (the application drives +-- 'applyAsyncProjection' per event), so this is the entry point an application +-- calls to surface lag for a subscription. recordProjectionLag :: - (IOE :> es, Store :> es) => - Maybe KeiroMetrics -> - AsyncProjection -> - Eff es () + (IOE :> es, Store :> es) => + Maybe KeiroMetrics -> + AsyncProjection -> + Eff es () recordProjectionLag metrics projection = do - headPos <- storeHeadPosition - checkpoint <- - fromMaybe (GlobalPosition 0) - <$> readSubscriptionPosition (projection ^. #subscriptionName) - Telemetry.recordProjectionLag metrics (positionGap headPos checkpoint) + headPos <- storeHeadPosition + checkpoint <- + fromMaybe (GlobalPosition 0) + <$> readSubscriptionPosition (projection ^. #subscriptionName) + Telemetry.recordProjectionLag metrics (positionGap headPos checkpoint) -- | The non-negative gap between the log head and a checkpoint, in events. positionGap :: GlobalPosition -> GlobalPosition -> Int64 @@ -212,39 +204,39 @@ insertProjectionDedupStmt :: Statement (Text, UUID) Bool insertProjectionDedupStmt = - preparable - """ - INSERT INTO keiro.keiro_projection_dedup (projection_name, event_id) - VALUES ($1, $2) - ON CONFLICT (projection_name, event_id) DO NOTHING - """ - ( contrazip2 - (E.param (E.nonNullable E.text)) - (E.param (E.nonNullable E.uuid)) - ) - ((> 0) <$> D.rowsAffected) + preparable + """ + INSERT INTO keiro.keiro_projection_dedup (projection_name, event_id) + VALUES ($1, $2) + ON CONFLICT (projection_name, event_id) DO NOTHING + """ + ( contrazip2 + (E.param (E.nonNullable E.text)) + (E.param (E.nonNullable E.uuid)) + ) + ((> 0) <$> D.rowsAffected) lockReadModelStatusStmt :: Statement Text (Maybe Text) lockReadModelStatusStmt = - preparable - """ - SELECT status - FROM keiro.keiro_read_models - WHERE name = $1 - FOR SHARE - """ - (E.param (E.nonNullable E.text)) - (D.rowMaybe (D.column (D.nonNullable D.text))) + preparable + """ + SELECT status + FROM keiro.keiro_read_models + WHERE name = $1 + FOR SHARE + """ + (E.param (E.nonNullable E.text)) + (D.rowMaybe (D.column (D.nonNullable D.text))) pruneProjectionDedupBeforeStmt :: Statement UTCTime Int64 pruneProjectionDedupBeforeStmt = - preparable - """ - DELETE FROM keiro.keiro_projection_dedup - WHERE applied_at < $1 - """ - (E.param (E.nonNullable E.timestamptz)) - D.rowsAffected + preparable + """ + DELETE FROM keiro.keiro_projection_dedup + WHERE applied_at < $1 + """ + (E.param (E.nonNullable E.timestamptz)) + D.rowsAffected eventIdToUuid :: EventId -> UUID eventIdToUuid (EventId value) = value diff --git a/src/Keiro/ReadModel.hs b/src/Keiro/ReadModel.hs --- a/src/Keiro/ReadModel.hs +++ b/src/Keiro/ReadModel.hs @@ -1,32 +1,31 @@ -{- | Querying the read side, with explicit consistency. - -A 'ReadModel' is a named, versioned SQL projection table plus the query that -reads it. Querying it does more than run SQL: 'runQuery' first verifies the -table's registered schema is current and 'Live' (rejecting a stale or -mid-rebuild model), then honours the requested 'ConsistencyMode' before -running the query in a transaction. - -The consistency modes trade freshness against latency: - -* 'Strong' — capture the store head position at query start and block until - the model's subscription cursor reaches it. -* 'Eventual' — query immediately. Read-your-writes is the projection worker's - responsibility under 'Eventual'. -* 'PositionWait' — block until the model's subscription has caught up to a - target 'GlobalPosition' (typically the position returned by the command - the caller just ran), giving read-your-writes against an asynchronous - projection. 'waitFor' implements the polling loop and times out with - 'ReadModelWaitTimeout'. - -Schema lifecycle (registration, status transitions) lives in -"Keiro.ReadModel.Schema", which is re-exported here. - -Register each model once at projection startup with 'registerReadModel' before -serving queries. Queries fail with 'ReadModelUnregistered' when startup wiring -has not registered the model; they never create registry rows themselves. --} -module Keiro.ReadModel ( - -- * Definition +-- | Querying the read side, with explicit consistency. +-- +-- A 'ReadModel' is a named, versioned SQL projection table plus the query that +-- reads it. Querying it does more than run SQL: 'runQuery' first verifies the +-- table's registered schema is current and 'Live' (rejecting a stale or +-- mid-rebuild model), then honours the requested 'ConsistencyMode' before +-- running the query in a transaction. +-- +-- The consistency modes trade freshness against latency: +-- +-- * 'Strong' — capture the store head position at query start and block until +-- the model's subscription cursor reaches it. +-- * 'Eventual' — query immediately. Read-your-writes is the projection worker's +-- responsibility under 'Eventual'. +-- * 'PositionWait' — block until the model's subscription has caught up to a +-- target 'GlobalPosition' (typically the position returned by the command +-- the caller just ran), giving read-your-writes against an asynchronous +-- projection. 'waitFor' implements the polling loop and times out with +-- 'ReadModelWaitTimeout'. +-- +-- Schema lifecycle (registration, status transitions) lives in +-- "Keiro.ReadModel.Schema", which is re-exported here. +-- +-- Register each model once at projection startup with 'registerReadModel' before +-- serving queries. Queries fail with 'ReadModelUnregistered' when startup wiring +-- has not registered the model; they never create registry rows themselves. +module Keiro.ReadModel + ( -- * Definition ReadModel (..), qualifiedTableName, @@ -49,7 +48,7 @@ -- * Schema lifecycle module Keiro.ReadModel.Schema, -) + ) where import Control.Concurrent (threadDelay) @@ -70,297 +69,282 @@ import "hasql-transaction" Hasql.Transaction qualified as Tx import Prelude qualified -{- | A queryable read-side projection over a query input @q@ and result @r@. - -* 'name' — logical identity, also the key in the @keiro_read_models@ - registry. -* 'tableName' — the underlying projection table. -* 'schema' — the PostgreSQL schema the read-model /data/ table lives in. The - application qualifies its 'query' SQL against this schema (typically via - 'Keiro.Connection.qualifyTable' or 'qualifiedTableName'); Keiro does not - rewrite 'query'. This is the application's data schema and is entirely - separate from Keiro's own @keiro@ schema, where the @keiro_read_models@ - registry lives. It is deliberately not persisted (see 'ensureReadModel'). -* 'subscriptionName' — the cursor that tracks how far the projection worker - has consumed the event log; consulted by 'PositionWait'. -* 'version' \/ 'shapeHash' — schema identity; a query fails with - 'ReadModelStaleSchema' if the registered values diverge, forcing a rebuild. -* 'defaultConsistency' — the 'ConsistencyMode' used by 'runQuery'. -* 'strongScope' — the event-log head a 'Strong' query waits for. -* 'query' — the SQL read, as a 'Hasql.Transaction.Transaction'. --} +-- | A queryable read-side projection over a query input @q@ and result @r@. +-- +-- * 'name' — logical identity, also the key in the @keiro_read_models@ +-- registry. +-- * 'tableName' — the underlying projection table. +-- * 'schema' — the PostgreSQL schema the read-model /data/ table lives in. The +-- application qualifies its 'query' SQL against this schema (typically via +-- 'Keiro.Connection.qualifyTable' or 'qualifiedTableName'); Keiro does not +-- rewrite 'query'. This is the application's data schema and is entirely +-- separate from Keiro's own @keiro@ schema, where the @keiro_read_models@ +-- registry lives. It is deliberately not persisted (see 'ensureReadModel'). +-- * 'subscriptionName' — the cursor that tracks how far the projection worker +-- has consumed the event log; consulted by 'PositionWait'. +-- * 'version' \/ 'shapeHash' — schema identity; a query fails with +-- 'ReadModelStaleSchema' if the registered values diverge, forcing a rebuild. +-- * 'defaultConsistency' — the 'ConsistencyMode' used by 'runQuery'. +-- * 'strongScope' — the event-log head a 'Strong' query waits for. +-- * 'query' — the SQL read, as a 'Hasql.Transaction.Transaction'. data ReadModel q r = ReadModel - { name :: !Text - , tableName :: !Text - , schema :: !Text - , subscriptionName :: !Text - , version :: !Int - , shapeHash :: !Text - , defaultConsistency :: !ConsistencyMode - , strongScope :: !StrongScope - , query :: !(q -> Tx.Transaction r) - } - deriving stock (Generic) + { name :: !Text, + tableName :: !Text, + schema :: !Text, + subscriptionName :: !Text, + version :: !Int, + shapeHash :: !Text, + defaultConsistency :: !ConsistencyMode, + strongScope :: !StrongScope, + query :: !(q -> Tx.Transaction r) + } + deriving stock (Generic) -{- | The read model's fully-qualified, double-quoted table reference -@"schema"."table"@, for interpolation into the application's projection SQL. -Equal to @'Keiro.Connection.qualifyTable' ('schema' rm) ('tableName' rm)@. --} +-- | The read model's fully-qualified, double-quoted table reference +-- @"schema"."table"@, for interpolation into the application's projection SQL. +-- Equal to @'Keiro.Connection.qualifyTable' ('schema' rm) ('tableName' rm)@. qualifiedTableName :: ReadModel q r -> Text qualifiedTableName readModel = - qualifyTable (readModel ^. #schema) (readModel ^. #tableName) - -{- | How fresh a read must be before the query runs. + qualifyTable (readModel ^. #schema) (readModel ^. #tableName) -'Strong' waits for the model's subscription to reach the store head captured -at query start according to the model's 'strongScope'. It is intended for -asynchronous read models with a worker advancing that subscription cursor; -inline-only models should use 'Eventual' because they have no subscription -worker to advance while waiting. -'PositionWait' blocks until the projection has caught up to a caller-supplied -target log position (or times out). 'Eventual' queries immediately. --} +-- | How fresh a read must be before the query runs. +-- +-- 'Strong' waits for the model's subscription to reach the store head captured +-- at query start according to the model's 'strongScope'. It is intended for +-- asynchronous read models with a worker advancing that subscription cursor; +-- inline-only models should use 'Eventual' because they have no subscription +-- worker to advance while waiting. +-- 'PositionWait' blocks until the projection has caught up to a caller-supplied +-- target log position (or times out). 'Eventual' queries immediately. data ConsistencyMode - = Strong - | Eventual - | PositionWait !PositionWaitOptions - deriving stock (Generic, Eq, Show) - -{- | Which log head a 'Strong' read must reach. - -'EntireLog' preserves the original behavior and is live only when the model's -subscription observes every event. A category subscription should use -'CategoryHead' with its Kiroku category, so unrelated categories cannot hold -the read behind forever. A model fed by multiple categories should use -'PositionWait' for an explicit write position or 'EntireLog' with a matching -all-stream subscription. + = Strong + | Eventual + | PositionWait !PositionWaitOptions + deriving stock (Generic, Eq, Show) -Kiroku currently does not advance category checkpoints on empty fetches. If it -does so in a future release, category-scoped targets may become unnecessary, -but the explicit model contract remains valid. --} +-- | Which log head a 'Strong' read must reach. +-- +-- 'EntireLog' preserves the original behavior and is live only when the model's +-- subscription observes every event. A category subscription should use +-- 'CategoryHead' with its Kiroku category, so unrelated categories cannot hold +-- the read behind forever. A model fed by multiple categories should use +-- 'PositionWait' for an explicit write position or 'EntireLog' with a matching +-- all-stream subscription. +-- +-- Kiroku currently does not advance category checkpoints on empty fetches. If it +-- does so in a future release, category-scoped targets may become unnecessary, +-- but the explicit model contract remains valid. data StrongScope - = EntireLog - | CategoryHead !Text - deriving stock (Generic, Eq, Show) - -{- | Parameters for a 'PositionWait' query. + = EntireLog + | CategoryHead !Text + deriving stock (Generic, Eq, Show) -* 'target' — the 'GlobalPosition' the projection must reach; 'Nothing' - skips waiting entirely. -* 'timeoutMicros' — give up after this long with 'ReadModelWaitTimeout'. -* 'pollMicros' — delay between subscription-position checks. --} +-- | Parameters for a 'PositionWait' query. +-- +-- * 'target' — the 'GlobalPosition' the projection must reach; 'Nothing' +-- skips waiting entirely. +-- * 'timeoutMicros' — give up after this long with 'ReadModelWaitTimeout'. +-- * 'pollMicros' — delay between subscription-position checks. data PositionWaitOptions = PositionWaitOptions - { target :: !(Maybe GlobalPosition) - , timeoutMicros :: !Int - , pollMicros :: !Int - } - deriving stock (Generic, Eq, Show) + { target :: !(Maybe GlobalPosition), + timeoutMicros :: !Int, + pollMicros :: !Int + } + deriving stock (Generic, Eq, Show) -{- | Default wait settings used by 'Strong': wait up to five seconds, polling -every 10ms, for the store head captured at query start. --} +-- | Default wait settings used by 'Strong': wait up to five seconds, polling +-- every 10ms, for the store head captured at query start. defaultStrongWaitOptions :: PositionWaitOptions defaultStrongWaitOptions = - PositionWaitOptions - { target = Nothing - , timeoutMicros = 5000000 - , pollMicros = 10000 - } + PositionWaitOptions + { target = Nothing, + timeoutMicros = 5000000, + pollMicros = 10000 + } -- | Why a read-model query could not run. data ReadModelError - = {- | No registry row exists for the model. Register it once at projection - startup with 'registerReadModel' before serving queries. - -} - ReadModelUnregistered !Text - | {- | The registered schema (version or shape hash) differs from the - model's current definition: name, expected vs. found version, then - expected vs. found shape hash. The model must be rebuilt. - -} - ReadModelStaleSchema !Text !Int !Int !Text !Text - | {- | A 'PositionWait' query timed out: model name, target position, and - the last observed subscription position. - -} - ReadModelWaitTimeout !Text !GlobalPosition !GlobalPosition - | {- | The model is registered but not 'Live' (e.g. rebuilding or - abandoned): name and current status. - -} - ReadModelNotLive !Text !ReadModelStatus - deriving stock (Generic, Eq, Show) + = -- | No registry row exists for the model. Register it once at projection + -- startup with 'registerReadModel' before serving queries. + ReadModelUnregistered !Text + | -- | The registered schema (version or shape hash) differs from the + -- model's current definition: name, expected vs. found version, then + -- expected vs. found shape hash. The model must be rebuilt. + ReadModelStaleSchema !Text !Int !Int !Text !Text + | -- | A 'PositionWait' query timed out: model name, target position, and + -- the last observed subscription position. + ReadModelWaitTimeout !Text !GlobalPosition !GlobalPosition + | -- | The model is registered but not 'Live' (e.g. rebuilding or + -- abandoned): name and current status. + ReadModelNotLive !Text !ReadModelStatus + deriving stock (Generic, Eq, Show) -{- | Query a read model using its 'defaultConsistency'. Validates schema and -liveness first, waits if the mode requires it, then runs the query. --} +-- | Query a read model using its 'defaultConsistency'. Validates schema and +-- liveness first, waits if the mode requires it, then runs the query. runQuery :: - (IOE :> es, Store :> es) => - Maybe KeiroMetrics -> - ReadModel q r -> - q -> - Eff es (Either ReadModelError r) + (IOE :> es, Store :> es) => + Maybe KeiroMetrics -> + ReadModel q r -> + q -> + Eff es (Either ReadModelError r) runQuery metrics readModel = - runQueryWith metrics (readModel ^. #defaultConsistency) readModel + runQueryWith metrics (readModel ^. #defaultConsistency) readModel -{- | Query a read model with an explicit 'ConsistencyMode', overriding its -default. Validates the model's schema and liveness, honours the wait mode, -then runs the query in a transaction. --} +-- | Query a read model with an explicit 'ConsistencyMode', overriding its +-- default. Validates the model's schema and liveness, honours the wait mode, +-- then runs the query in a transaction. runQueryWith :: - (IOE :> es, Store :> es) => - Maybe KeiroMetrics -> - ConsistencyMode -> - ReadModel q r -> - q -> - Eff es (Either ReadModelError r) + (IOE :> es, Store :> es) => + Maybe KeiroMetrics -> + ConsistencyMode -> + ReadModel q r -> + q -> + Eff es (Either ReadModelError r) runQueryWith metrics consistency readModel input = do - schemaCheck <- ensureReadModel readModel - case schemaCheck of + schemaCheck <- ensureReadModel readModel + case schemaCheck of + Left err -> pure (Left err) + Right () -> do + waitResult <- waitIfNeeded metrics consistency readModel + case waitResult of Left err -> pure (Left err) - Right () -> do - waitResult <- waitIfNeeded metrics consistency readModel - case waitResult of - Left err -> pure (Left err) - Right () -> Right <$> runTransaction ((readModel ^. #query) input) + Right () -> Right <$> runTransaction ((readModel ^. #query) input) -{- | Block until the model's subscription has advanced to @targetPosition@, -polling at 'pollMicros' intervals. Returns @Right ()@ once caught up, or -'ReadModelWaitTimeout' if 'timeoutMicros' elapses first. --} +-- | Block until the model's subscription has advanced to @targetPosition@, +-- polling at 'pollMicros' intervals. Returns @Right ()@ once caught up, or +-- 'ReadModelWaitTimeout' if 'timeoutMicros' elapses first. waitFor :: - (IOE :> es, Store :> es) => - Maybe KeiroMetrics -> - PositionWaitOptions -> - ReadModel q r -> - GlobalPosition -> - Eff es (Either ReadModelError ()) + (IOE :> es, Store :> es) => + Maybe KeiroMetrics -> + PositionWaitOptions -> + ReadModel q r -> + GlobalPosition -> + Eff es (Either ReadModelError ()) waitFor metrics options readModel targetPosition = do - started <- liftIO getCurrentTime - poll started (GlobalPosition 0) + started <- liftIO getCurrentTime + poll started (GlobalPosition 0) where poll started observed = do - current <- readSubscriptionPosition (readModel ^. #subscriptionName) - let observed' = fromMaybe observed current - if observed' >= targetPosition - then pure (Right ()) + current <- readSubscriptionPosition (readModel ^. #subscriptionName) + let observed' = fromMaybe observed current + if observed' >= targetPosition + then pure (Right ()) + else do + now <- liftIO getCurrentTime + let elapsedMicros = + Prelude.floor + (diffUTCTime now started Prelude.* 1000000) + if elapsedMicros >= options ^. #timeoutMicros + then do + -- A genuine give-up: bump keiro.projection.wait.timeouts (no-op + -- under a 'Nothing' handle) before surfacing the timeout. + recordProjectionWaitTimeouts metrics 1 + pure + (Left (ReadModelWaitTimeout (readModel ^. #name) targetPosition observed')) else do - now <- liftIO getCurrentTime - let elapsedMicros = - Prelude.floor - (diffUTCTime now started Prelude.* 1000000) - if elapsedMicros >= options ^. #timeoutMicros - then do - -- A genuine give-up: bump keiro.projection.wait.timeouts (no-op - -- under a 'Nothing' handle) before surfacing the timeout. - recordProjectionWaitTimeouts metrics 1 - pure - (Left (ReadModelWaitTimeout (readModel ^. #name) targetPosition observed')) - else do - liftIO (threadDelay (options ^. #pollMicros)) - poll started observed' + liftIO (threadDelay (options ^. #pollMicros)) + poll started observed' -- Note: the read model's 'schema' field is deliberately NOT persisted here. The -- registry keys on name/version/shapeHash/status (the model's schema identity); -- where the application's data table physically lives is a deployment/wiring -- concern, not part of that identity. See EP-4's Decision Log. ensureReadModel :: - (Store :> es) => - ReadModel q r -> - Eff es (Either ReadModelError ()) + (Store :> es) => + ReadModel q r -> + Eff es (Either ReadModelError ()) ensureReadModel readModel = do - found <- lookupReadModel (readModel ^. #name) - pure $ case found of - Just metadata -> validateMetadata readModel metadata - Nothing -> Left (ReadModelUnregistered (readModel ^. #name)) + found <- lookupReadModel (readModel ^. #name) + pure $ case found of + Just metadata -> validateMetadata readModel metadata + Nothing -> Left (ReadModelUnregistered (readModel ^. #name)) validateMetadata :: ReadModel q r -> ReadModelMetadata -> Either ReadModelError () validateMetadata readModel metadata - | metadata ^. #version /= readModel ^. #version = - stale - | metadata ^. #shapeHash /= readModel ^. #shapeHash = - stale - | metadata ^. #status /= Live = - Left (ReadModelNotLive (readModel ^. #name) (metadata ^. #status)) - | otherwise = - Right () + | metadata ^. #version /= readModel ^. #version = + stale + | metadata ^. #shapeHash /= readModel ^. #shapeHash = + stale + | metadata ^. #status /= Live = + Left (ReadModelNotLive (readModel ^. #name) (metadata ^. #status)) + | otherwise = + Right () where stale = - Left - ( ReadModelStaleSchema - (readModel ^. #name) - (readModel ^. #version) - (metadata ^. #version) - (readModel ^. #shapeHash) - (metadata ^. #shapeHash) - ) + Left + ( ReadModelStaleSchema + (readModel ^. #name) + (readModel ^. #version) + (metadata ^. #version) + (readModel ^. #shapeHash) + (metadata ^. #shapeHash) + ) waitIfNeeded :: - (IOE :> es, Store :> es) => - Maybe KeiroMetrics -> - ConsistencyMode -> - ReadModel q r -> - Eff es (Either ReadModelError ()) + (IOE :> es, Store :> es) => + Maybe KeiroMetrics -> + ConsistencyMode -> + ReadModel q r -> + Eff es (Either ReadModelError ()) waitIfNeeded metrics Strong readModel = do - target <- case readModel ^. #strongScope of - EntireLog -> storeHeadPosition - CategoryHead category -> categoryHeadPosition category - waitFor metrics (defaultStrongWaitOptions & #target ?~ target) readModel target + target <- case readModel ^. #strongScope of + EntireLog -> storeHeadPosition + CategoryHead category -> categoryHeadPosition category + waitFor metrics (defaultStrongWaitOptions & #target ?~ target) readModel target waitIfNeeded _ Eventual _ = pure (Right ()) waitIfNeeded metrics (PositionWait options) readModel = - case options ^. #target of - Nothing -> pure (Right ()) - Just targetPosition -> waitFor metrics options readModel targetPosition + case options ^. #target of + Nothing -> pure (Right ()) + Just targetPosition -> waitFor metrics options readModel targetPosition readSubscriptionPosition :: - (Store :> es) => - Text -> - Eff es (Maybe GlobalPosition) + (Store :> es) => + Text -> + Eff es (Maybe GlobalPosition) readSubscriptionPosition subscriptionName = - runTransaction - $ Tx.statement subscriptionName lookupSubscriptionPositionStmt + runTransaction + $ Tx.statement subscriptionName lookupSubscriptionPositionStmt lookupSubscriptionPositionStmt :: Statement Text (Maybe GlobalPosition) lookupSubscriptionPositionStmt = - preparable - """ - SELECT min(last_seen) - FROM subscriptions - WHERE subscription_name = $1 - """ - (E.param (E.nonNullable E.text)) - (D.singleRow (fmap GlobalPosition <$> D.column (D.nullable D.int8))) + preparable + """ + SELECT min(last_seen) + FROM subscriptions + WHERE subscription_name = $1 + """ + (E.param (E.nonNullable E.text)) + (D.singleRow (fmap GlobalPosition <$> D.column (D.nullable D.int8))) -{- | The global position of the most recent event in the @$all@ log, or -@GlobalPosition 0@ when the log is empty. 'readAllBackward' treats -@GlobalPosition 0@ as "after everything", so a limit of 1 returns the head. --} +-- | The global position of the most recent event in the @$all@ log, or +-- @GlobalPosition 0@ when the log is empty. 'readAllBackward' treats +-- @GlobalPosition 0@ as "after everything", so a limit of 1 returns the head. storeHeadPosition :: (Store :> es) => Eff es GlobalPosition storeHeadPosition = do - recent <- readAllBackward (GlobalPosition 0) 1 - pure $ case Vector.toList recent of - (event : _) -> event ^. #globalPosition - [] -> GlobalPosition 0 + recent <- readAllBackward (GlobalPosition 0) 1 + pure $ case Vector.toList recent of + (event : _) -> event ^. #globalPosition + [] -> GlobalPosition 0 -{- | The latest global position originating in a Kiroku category, or -@GlobalPosition 0@ when that category has no events. This deliberately reads -Kiroku's indexed @streams@ and @$all@ membership tables because Kiroku 0.3 does -not export a category-head query. --} +-- | The latest global position originating in a Kiroku category, or +-- @GlobalPosition 0@ when that category has no events. This deliberately reads +-- Kiroku's indexed @streams@ and @$all@ membership tables because Kiroku 0.3 does +-- not export a category-head query. categoryHeadPosition :: (Store :> es) => Text -> Eff es GlobalPosition categoryHeadPosition category = - runTransaction - $ Tx.statement category categoryHeadPositionStmt + runTransaction + $ Tx.statement category categoryHeadPositionStmt categoryHeadPositionStmt :: Statement Text GlobalPosition categoryHeadPositionStmt = - preparable - """ - SELECT COALESCE(max(se.stream_version), 0) - FROM streams s - JOIN stream_events se - ON se.original_stream_id = s.stream_id - AND se.stream_id = 0 - WHERE s.category = $1 - """ - (E.param (E.nonNullable E.text)) - (D.singleRow (GlobalPosition <$> D.column (D.nonNullable D.int8))) + preparable + """ + SELECT COALESCE(max(se.stream_version), 0) + FROM streams s + JOIN stream_events se + ON se.original_stream_id = s.stream_id + AND se.stream_id = 0 + WHERE s.category = $1 + """ + (E.param (E.nonNullable E.text)) + (D.singleRow (GlobalPosition <$> D.column (D.nonNullable D.int8))) diff --git a/src/Keiro/ReadModel/Rebuild.hs b/src/Keiro/ReadModel/Rebuild.hs --- a/src/Keiro/ReadModel/Rebuild.hs +++ b/src/Keiro/ReadModel/Rebuild.hs @@ -1,39 +1,38 @@ -{- | The supported offline read-model rebuild lifecycle. - -Use this checklist rather than composing the low-level status transitions: - -1. Call 'Keiro.ReadModel.Schema.registerReadModel' once at projection startup. - Explicit registration makes misspelled or never-populated models fail with - 'ReadModelUnregistered' instead of appearing healthy. -2. Call 'startRebuild' with every feeding async projection name and the replay - position. It atomically fences live writers, takes queries offline, truncates - the data table, clears the named dedup keys, and resets the subscription - checkpoint, preventing live/replay interleaving and all-deduplicated rebuilds. -3. Replay through 'Keiro.Projection.applyAsyncProjectionUnfenced'. This is the - only apply path allowed to bypass the live-writer fence, while retaining - deduplication inside the designated rebuild. -4. After replay catches up and application-specific verification succeeds, call - 'finishRebuild' with the same projection names and replay position. Its - promotion guard refuses to serve a non-empty-log rebuild that applied no - events. -5. If replay or verification fails, call 'abandonRebuild'. Queries remain - unavailable instead of exposing partial data; repair or restore the table - before beginning another rebuild. - -Normal workers continue to call 'Keiro.Projection.applyAsyncProjection'. Its -registry lock fences them automatically while the model is rebuilding, but they -must not checkpoint an 'Keiro.Projection.AsyncFenced' event. Keiro does not yet -provide a shadow-table or online cutover mechanism; applications that need -zero-downtime rebuilds must build that orchestration above this lifecycle API. --} -module Keiro.ReadModel.Rebuild ( - RebuildError (..), +-- | The supported offline read-model rebuild lifecycle. +-- +-- Use this checklist rather than composing the low-level status transitions: +-- +-- 1. Call 'Keiro.ReadModel.Schema.registerReadModel' once at projection startup. +-- Explicit registration makes misspelled or never-populated models fail with +-- 'ReadModelUnregistered' instead of appearing healthy. +-- 2. Call 'startRebuild' with every feeding async projection name and the replay +-- position. It atomically fences live writers, takes queries offline, truncates +-- the data table, clears the named dedup keys, and resets the subscription +-- checkpoint, preventing live/replay interleaving and all-deduplicated rebuilds. +-- 3. Replay through 'Keiro.Projection.applyAsyncProjectionUnfenced'. This is the +-- only apply path allowed to bypass the live-writer fence, while retaining +-- deduplication inside the designated rebuild. +-- 4. After replay catches up and application-specific verification succeeds, call +-- 'finishRebuild' with the same projection names and replay position. Its +-- promotion guard refuses to serve a non-empty-log rebuild that applied no +-- events. +-- 5. If replay or verification fails, call 'abandonRebuild'. Queries remain +-- unavailable instead of exposing partial data; repair or restore the table +-- before beginning another rebuild. +-- +-- Normal workers continue to call 'Keiro.Projection.applyAsyncProjection'. Its +-- registry lock fences them automatically while the model is rebuilding, but they +-- must not checkpoint an 'Keiro.Projection.AsyncFenced' event. Keiro does not yet +-- provide a shadow-table or online cutover mechanism; applications that need +-- zero-downtime rebuilds must build that orchestration above this lifecycle API. +module Keiro.ReadModel.Rebuild + ( RebuildError (..), startRebuild, finishRebuild, rebuild, promote, abandonRebuild, -) + ) where import Contravariant.Extras (contrazip2) @@ -51,146 +50,141 @@ -- | Why a rebuild could not be promoted. data RebuildError - = {- | The model name and current store head when a rebuild started before - existing events but applied none of its feeding projections. - -} - RebuildProducedNoApplies !Text !GlobalPosition - deriving stock (Generic, Eq, Show) - -{- | Atomically take a model offline, truncate its data table, clear the dedup -keys for its feeding async projections, and reset every member of its -subscription to the supplied replay position. + = -- | The model name and current store head when a rebuild started before + -- existing events but applied none of its feeding projections. + RebuildProducedNoApplies !Text !GlobalPosition + deriving stock (Generic, Eq, Show) -The registry transition runs first and holds the row lock that -'Keiro.Projection.applyAsyncProjection' uses as its writer fence. PostgreSQL -keeps the table truncate transactional. Kiroku's public checkpoint save is -monotonic, so this helper deliberately resets @subscriptions.last_seen@ -directly inside the same fenced transaction. --} +-- | Atomically take a model offline, truncate its data table, clear the dedup +-- keys for its feeding async projections, and reset every member of its +-- subscription to the supplied replay position. +-- +-- The registry transition runs first and holds the row lock that +-- 'Keiro.Projection.applyAsyncProjection' uses as its writer fence. PostgreSQL +-- keeps the table truncate transactional. Kiroku's public checkpoint save is +-- monotonic, so this helper deliberately resets @subscriptions.last_seen@ +-- directly inside the same fenced transaction. startRebuild :: - (Store :> es) => - ReadModel q r -> - [Text] -> - GlobalPosition -> - Eff es ReadModelMetadata + (Store :> es) => + ReadModel q r -> + [Text] -> + GlobalPosition -> + Eff es ReadModelMetadata startRebuild readModel projectionNames replayFrom = - runTransaction $ do - metadata <- transitionReadModelTxFor readModel Rebuilding - Tx.sql (TE.encodeUtf8 ("TRUNCATE TABLE " <> qualifiedTableName readModel)) - unless (null projectionNames) $ - Tx.statement projectionNames deleteProjectionDedupStmt - Tx.statement - (readModel ^. #subscriptionName, globalPositionToInt replayFrom) - resetSubscriptionCheckpointStmt - pure metadata - -{- | Promote a completed rebuild in the same transaction as its safety check. + runTransaction $ do + metadata <- transitionReadModelTxFor readModel Rebuilding + Tx.sql (TE.encodeUtf8 ("TRUNCATE TABLE " <> qualifiedTableName readModel)) + unless (null projectionNames) $ + Tx.statement projectionNames deleteProjectionDedupStmt + Tx.statement + (readModel ^. #subscriptionName, globalPositionToInt replayFrom) + resetSubscriptionCheckpointStmt + pure metadata -When async projection names are supplied, a store head beyond @replayFrom@ -requires at least one new dedup row. 'startRebuild' deleted those rows, so their -count is the model-independent number of projection applications during this -rebuild. An empty projection-name list denotes an inline-only model and skips -the guard because no async dedup rows can exist for it. --} +-- | Promote a completed rebuild in the same transaction as its safety check. +-- +-- When async projection names are supplied, a store head beyond @replayFrom@ +-- requires at least one new dedup row. 'startRebuild' deleted those rows, so their +-- count is the model-independent number of projection applications during this +-- rebuild. An empty projection-name list denotes an inline-only model and skips +-- the guard because no async dedup rows can exist for it. finishRebuild :: - (Store :> es) => - ReadModel q r -> - [Text] -> - GlobalPosition -> - Eff es (Either RebuildError ReadModelMetadata) + (Store :> es) => + ReadModel q r -> + [Text] -> + GlobalPosition -> + Eff es (Either RebuildError ReadModelMetadata) finishRebuild readModel projectionNames replayFrom = - runTransaction $ do - headPosition <- Tx.statement () storeHeadPositionStmt - applyCount <- - if null projectionNames - then pure 0 - else Tx.statement projectionNames countProjectionDedupStmt - if null projectionNames || applyCount > 0 || headPosition <= replayFrom - then Right <$> transitionReadModelTxFor readModel Live - else pure (Left (RebuildProducedNoApplies (readModel ^. #name) headPosition)) + runTransaction $ do + headPosition <- Tx.statement () storeHeadPositionStmt + applyCount <- + if null projectionNames + then pure 0 + else Tx.statement projectionNames countProjectionDedupStmt + if null projectionNames || applyCount > 0 || headPosition <= replayFrom + then Right <$> transitionReadModelTxFor readModel Live + else pure (Left (RebuildProducedNoApplies (readModel ^. #name) headPosition)) -{- | Low-level status transition only. It does not truncate data, reset dedup -keys or checkpoints, or establish the complete rebuild workflow. Use -'startRebuild' for supported rebuilds. --} +-- | Low-level status transition only. It does not truncate data, reset dedup +-- keys or checkpoints, or establish the complete rebuild workflow. Use +-- 'startRebuild' for supported rebuilds. rebuild :: (Store :> es) => ReadModel q r -> Eff es ReadModelMetadata rebuild readModel = - markRebuilding - (readModel ^. #name) - (readModel ^. #version) - (readModel ^. #shapeHash) + markRebuilding + (readModel ^. #name) + (readModel ^. #version) + (readModel ^. #shapeHash) -{- | Low-level status transition only. It bypasses the empty-rebuild guard. Use -'finishRebuild' to promote a supported rebuild. --} +-- | Low-level status transition only. It bypasses the empty-rebuild guard. Use +-- 'finishRebuild' to promote a supported rebuild. promote :: (Store :> es) => ReadModel q r -> Eff es ReadModelMetadata promote readModel = - markLive - (readModel ^. #name) - (readModel ^. #version) - (readModel ^. #shapeHash) + markLive + (readModel ^. #name) + (readModel ^. #version) + (readModel ^. #shapeHash) -- | Mark a model 'Abandoned', backing out of an in-progress rebuild. abandonRebuild :: (Store :> es) => ReadModel q r -> Eff es ReadModelMetadata abandonRebuild readModel = - markAbandoned - (readModel ^. #name) - (readModel ^. #version) - (readModel ^. #shapeHash) + markAbandoned + (readModel ^. #name) + (readModel ^. #version) + (readModel ^. #shapeHash) transitionReadModelTxFor :: ReadModel q r -> ReadModelStatus -> Tx.Transaction ReadModelMetadata transitionReadModelTxFor readModel status = - transitionReadModelTx - (readModel ^. #name) - (readModel ^. #version) - (readModel ^. #shapeHash) - status + transitionReadModelTx + (readModel ^. #name) + (readModel ^. #version) + (readModel ^. #shapeHash) + status deleteProjectionDedupStmt :: Statement [Text] () deleteProjectionDedupStmt = - preparable - """ - DELETE FROM keiro.keiro_projection_dedup - WHERE projection_name = ANY($1) - """ - (E.param (E.nonNullable (E.foldableArray (E.nonNullable E.text)))) - D.noResult + preparable + """ + DELETE FROM keiro.keiro_projection_dedup + WHERE projection_name = ANY($1) + """ + (E.param (E.nonNullable (E.foldableArray (E.nonNullable E.text)))) + D.noResult countProjectionDedupStmt :: Statement [Text] Int64 countProjectionDedupStmt = - preparable - """ - SELECT count(*) - FROM keiro.keiro_projection_dedup - WHERE projection_name = ANY($1) - """ - (E.param (E.nonNullable (E.foldableArray (E.nonNullable E.text)))) - (D.singleRow (D.column (D.nonNullable D.int8))) + preparable + """ + SELECT count(*) + FROM keiro.keiro_projection_dedup + WHERE projection_name = ANY($1) + """ + (E.param (E.nonNullable (E.foldableArray (E.nonNullable E.text)))) + (D.singleRow (D.column (D.nonNullable D.int8))) resetSubscriptionCheckpointStmt :: Statement (Text, Int64) () resetSubscriptionCheckpointStmt = - preparable - """ - UPDATE subscriptions - SET last_seen = $2, updated_at = now() - WHERE subscription_name = $1 - """ - ( contrazip2 - (E.param (E.nonNullable E.text)) - (E.param (E.nonNullable E.int8)) - ) - D.noResult + preparable + """ + UPDATE subscriptions + SET last_seen = $2, updated_at = now() + WHERE subscription_name = $1 + """ + ( contrazip2 + (E.param (E.nonNullable E.text)) + (E.param (E.nonNullable E.int8)) + ) + D.noResult storeHeadPositionStmt :: Statement () GlobalPosition storeHeadPositionStmt = - preparable - """ - SELECT COALESCE(max(stream_version), 0) - FROM stream_events - WHERE stream_id = 0 - """ - E.noParams - (D.singleRow (GlobalPosition <$> D.column (D.nonNullable D.int8))) + preparable + """ + SELECT COALESCE(max(stream_version), 0) + FROM stream_events + WHERE stream_id = 0 + """ + E.noParams + (D.singleRow (GlobalPosition <$> D.column (D.nonNullable D.int8))) globalPositionToInt :: GlobalPosition -> Int64 globalPositionToInt (GlobalPosition position) = position diff --git a/src/Keiro/ReadModel/Schema.hs b/src/Keiro/ReadModel/Schema.hs --- a/src/Keiro/ReadModel/Schema.hs +++ b/src/Keiro/ReadModel/Schema.hs @@ -1,19 +1,18 @@ -{- | The @keiro_read_models@ registry: schema identity and lifecycle status. - -Every read model explicitly registers a row at projection startup recording its 'version', 'shapeHash', and -'ReadModelStatus'. The registry is what lets 'Keiro.ReadModel.runQuery' -refuse to serve a model whose code-side schema has drifted from the table on -disk, or one that is mid-rebuild. The status transitions ('markRebuilding', -'markLive', 'markAbandoned') drive the rebuild workflow in -"Keiro.ReadModel.Rebuild". - -All operations run as single-statement 'Hasql.Transaction.Transaction's -against the @keiro_read_models@ table; an unrecognized stored status decodes -to 'UnknownStatus' so callers see the raw database value instead of a silent -fallback. --} -module Keiro.ReadModel.Schema ( - -- * Metadata +-- | The @keiro_read_models@ registry: schema identity and lifecycle status. +-- +-- Every read model explicitly registers a row at projection startup recording its 'version', 'shapeHash', and +-- 'ReadModelStatus'. The registry is what lets 'Keiro.ReadModel.runQuery' +-- refuse to serve a model whose code-side schema has drifted from the table on +-- disk, or one that is mid-rebuild. The status transitions ('markRebuilding', +-- 'markLive', 'markAbandoned') drive the rebuild workflow in +-- "Keiro.ReadModel.Rebuild". +-- +-- All operations run as single-statement 'Hasql.Transaction.Transaction's +-- against the @keiro_read_models@ table; an unrecognized stored status decodes +-- to 'UnknownStatus' so callers see the raw database value instead of a silent +-- fallback. +module Keiro.ReadModel.Schema + ( -- * Metadata ReadModelMetadata (..), ReadModelStatus (..), @@ -26,7 +25,7 @@ markLive, markAbandoned, transitionReadModelTx, -) + ) where import Contravariant.Extras (contrazip3, contrazip4) @@ -40,166 +39,159 @@ import "hasql-transaction" Hasql.Transaction qualified as Tx import Prelude qualified -{- | Lifecycle status of a registered read model. - -* 'Live' — current and queryable. -* 'Rebuilding' — being repopulated from the event log; not yet queryable. -* 'Paused' — temporarily not served. -* 'Abandoned' — a rebuild that was given up on. -* 'UnknownStatus' — a database value this library version does not recognize. --} +-- | Lifecycle status of a registered read model. +-- +-- * 'Live' — current and queryable. +-- * 'Rebuilding' — being repopulated from the event log; not yet queryable. +-- * 'Paused' — temporarily not served. +-- * 'Abandoned' — a rebuild that was given up on. +-- * 'UnknownStatus' — a database value this library version does not recognize. data ReadModelStatus - = Live - | Rebuilding - | Paused - | Abandoned - | UnknownStatus !Text - deriving stock (Generic, Eq, Show) + = Live + | Rebuilding + | Paused + | Abandoned + | UnknownStatus !Text + deriving stock (Generic, Eq, Show) -{- | One row of the @keiro_read_models@ registry: a model's name, schema -identity ('version' and 'shapeHash'), the time it was last (re)built, and -its current 'status'. --} +-- | One row of the @keiro_read_models@ registry: a model's name, schema +-- identity ('version' and 'shapeHash'), the time it was last (re)built, and +-- its current 'status'. data ReadModelMetadata = ReadModelMetadata - { name :: !Text - , version :: !Int - , shapeHash :: !Text - , lastBuiltAt :: !(Maybe UTCTime) - , status :: !ReadModelStatus - } - deriving stock (Generic, Eq, Show) + { name :: !Text, + version :: !Int, + shapeHash :: !Text, + lastBuiltAt :: !(Maybe UTCTime), + status :: !ReadModelStatus + } + deriving stock (Generic, Eq, Show) -{- | Register a read model once at projection startup, inserting a 'Live' row -if none exists. Querying never performs this registration automatically, so -deployments that previously relied on their first query to register must add -this startup call. Idempotent: -an existing registration is returned unchanged (the @version@ and -@shapeHash@ are /not/ overwritten), so a query can compare them and detect -schema drift. --} +-- | Register a read model once at projection startup, inserting a 'Live' row +-- if none exists. Querying never performs this registration automatically, so +-- deployments that previously relied on their first query to register must add +-- this startup call. Idempotent: +-- an existing registration is returned unchanged (the @version@ and +-- @shapeHash@ are /not/ overwritten), so a query can compare them and detect +-- schema drift. registerReadModel :: (Store :> es) => Text -> Int -> Text -> Eff es ReadModelMetadata registerReadModel name version shapeHash = - runTransaction - $ Tx.statement - (name, Prelude.fromIntegral version, shapeHash) - registerReadModelStmt + runTransaction + $ Tx.statement + (name, Prelude.fromIntegral version, shapeHash) + registerReadModelStmt -- | Look up a read model's registry row by name, if it exists. lookupReadModel :: (Store :> es) => Text -> Eff es (Maybe ReadModelMetadata) lookupReadModel name = - runTransaction - $ Tx.statement name lookupReadModelStmt + runTransaction + $ Tx.statement name lookupReadModelStmt -{- | Upsert the registry row to 'Rebuilding' at the given schema identity. -Marks the model as being repopulated so queries stop serving it until -'markLive'. --} +-- | Upsert the registry row to 'Rebuilding' at the given schema identity. +-- Marks the model as being repopulated so queries stop serving it until +-- 'markLive'. markRebuilding :: (Store :> es) => Text -> Int -> Text -> Eff es ReadModelMetadata markRebuilding name version shapeHash = - runTransaction $ transitionReadModelTx name version shapeHash Rebuilding + runTransaction $ transitionReadModelTx name version shapeHash Rebuilding -{- | Upsert the registry row to 'Live' at the given schema identity, stamping -@last_built_at@. Makes the model queryable again after a rebuild. --} +-- | Upsert the registry row to 'Live' at the given schema identity, stamping +-- @last_built_at@. Makes the model queryable again after a rebuild. markLive :: (Store :> es) => Text -> Int -> Text -> Eff es ReadModelMetadata markLive name version shapeHash = - runTransaction $ transitionReadModelTx name version shapeHash Live + runTransaction $ transitionReadModelTx name version shapeHash Live -{- | Upsert the registry row to 'Abandoned' at the given schema identity, -recording that a rebuild was given up on. --} +-- | Upsert the registry row to 'Abandoned' at the given schema identity, +-- recording that a rebuild was given up on. markAbandoned :: (Store :> es) => Text -> Int -> Text -> Eff es ReadModelMetadata markAbandoned name version shapeHash = - runTransaction $ transitionReadModelTx name version shapeHash Abandoned + runTransaction $ transitionReadModelTx name version shapeHash Abandoned -{- | Transaction-composable form of a registry status transition. Rebuild -orchestration uses this form so the status row lock, table reset, dedup reset, -and checkpoint reset share one database transaction. --} +-- | Transaction-composable form of a registry status transition. Rebuild +-- orchestration uses this form so the status row lock, table reset, dedup reset, +-- and checkpoint reset share one database transaction. transitionReadModelTx :: Text -> Int -> Text -> ReadModelStatus -> Tx.Transaction ReadModelMetadata transitionReadModelTx name version shapeHash status = - Tx.statement - (name, Prelude.fromIntegral version, shapeHash, statusToText status) - transitionReadModelStmt + Tx.statement + (name, Prelude.fromIntegral version, shapeHash, statusToText status) + transitionReadModelStmt registerReadModelStmt :: Statement (Text, Int64, Text) ReadModelMetadata registerReadModelStmt = - preparable - """ - INSERT INTO keiro.keiro_read_models (name, version, shape_hash, status, last_built_at) - VALUES ($1, $2, $3, 'live', now()) - ON CONFLICT (name) DO UPDATE - SET name = EXCLUDED.name - RETURNING name, version, shape_hash, last_built_at, status - """ - ( contrazip3 - (E.param (E.nonNullable E.text)) - (E.param (E.nonNullable E.int8)) - (E.param (E.nonNullable E.text)) - ) - readModelMetadataSingle + preparable + """ + INSERT INTO keiro.keiro_read_models (name, version, shape_hash, status, last_built_at) + VALUES ($1, $2, $3, 'live', now()) + ON CONFLICT (name) DO UPDATE + SET name = EXCLUDED.name + RETURNING name, version, shape_hash, last_built_at, status + """ + ( contrazip3 + (E.param (E.nonNullable E.text)) + (E.param (E.nonNullable E.int8)) + (E.param (E.nonNullable E.text)) + ) + readModelMetadataSingle lookupReadModelStmt :: Statement Text (Maybe ReadModelMetadata) lookupReadModelStmt = - preparable - """ - SELECT name, version, shape_hash, last_built_at, status - FROM keiro.keiro_read_models - WHERE name = $1 - """ - (E.param (E.nonNullable E.text)) - (D.rowMaybe readModelMetadataDecoder) + preparable + """ + SELECT name, version, shape_hash, last_built_at, status + FROM keiro.keiro_read_models + WHERE name = $1 + """ + (E.param (E.nonNullable E.text)) + (D.rowMaybe readModelMetadataDecoder) transitionReadModelStmt :: Statement (Text, Int64, Text, Text) ReadModelMetadata transitionReadModelStmt = - preparable - """ - INSERT INTO keiro.keiro_read_models (name, version, shape_hash, status, last_built_at, updated_at) - VALUES ($1, $2, $3, $4, now(), now()) - ON CONFLICT (name) DO UPDATE - SET version = EXCLUDED.version, - shape_hash = EXCLUDED.shape_hash, - status = EXCLUDED.status, - last_built_at = CASE - WHEN EXCLUDED.status = 'live' THEN now() - ELSE keiro_read_models.last_built_at - END, - updated_at = now() - RETURNING name, version, shape_hash, last_built_at, status - """ - ( contrazip4 - (E.param (E.nonNullable E.text)) - (E.param (E.nonNullable E.int8)) - (E.param (E.nonNullable E.text)) - (E.param (E.nonNullable E.text)) - ) - readModelMetadataSingle + preparable + """ + INSERT INTO keiro.keiro_read_models (name, version, shape_hash, status, last_built_at, updated_at) + VALUES ($1, $2, $3, $4, now(), now()) + ON CONFLICT (name) DO UPDATE + SET version = EXCLUDED.version, + shape_hash = EXCLUDED.shape_hash, + status = EXCLUDED.status, + last_built_at = CASE + WHEN EXCLUDED.status = 'live' THEN now() + ELSE keiro_read_models.last_built_at + END, + updated_at = now() + RETURNING name, version, shape_hash, last_built_at, status + """ + ( contrazip4 + (E.param (E.nonNullable E.text)) + (E.param (E.nonNullable E.int8)) + (E.param (E.nonNullable E.text)) + (E.param (E.nonNullable E.text)) + ) + readModelMetadataSingle readModelMetadataSingle :: D.Result ReadModelMetadata readModelMetadataSingle = - D.singleRow readModelMetadataDecoder + D.singleRow readModelMetadataDecoder readModelMetadataDecoder :: D.Row ReadModelMetadata readModelMetadataDecoder = - ReadModelMetadata - <$> D.column (D.nonNullable D.text) - <*> (Prelude.fromIntegral <$> D.column (D.nonNullable D.int8)) - <*> D.column (D.nonNullable D.text) - <*> D.column (D.nullable D.timestamptz) - <*> (statusFromText <$> D.column (D.nonNullable D.text)) + ReadModelMetadata + <$> D.column (D.nonNullable D.text) + <*> (Prelude.fromIntegral <$> D.column (D.nonNullable D.int8)) + <*> D.column (D.nonNullable D.text) + <*> D.column (D.nullable D.timestamptz) + <*> (statusFromText <$> D.column (D.nonNullable D.text)) statusToText :: ReadModelStatus -> Text statusToText = \case - Live -> "live" - Rebuilding -> "rebuilding" - Paused -> "paused" - Abandoned -> "abandoned" - UnknownStatus raw -> raw + Live -> "live" + Rebuilding -> "rebuilding" + Paused -> "paused" + Abandoned -> "abandoned" + UnknownStatus raw -> raw statusFromText :: Text -> ReadModelStatus statusFromText = \case - "live" -> Live - "rebuilding" -> Rebuilding - "paused" -> Paused - "abandoned" -> Abandoned - raw -> UnknownStatus raw + "live" -> Live + "rebuilding" -> Rebuilding + "paused" -> Paused + "abandoned" -> Abandoned + raw -> UnknownStatus raw diff --git a/src/Keiro/ReplayAudit.hs b/src/Keiro/ReplayAudit.hs --- a/src/Keiro/ReplayAudit.hs +++ b/src/Keiro/ReplayAudit.hs @@ -1,22 +1,21 @@ {-# LANGUAGE GADTs #-} -{- | Read-only, differential replay audits for aggregate event streams. - -Routine deploys should first consume @keiro-dsl diff@'s replay-impact verdict: -a replay-neutral deploy touches no data, while an affected verdict supplies the -event types for 'AuditTargeted'. 'AuditFull' is intentionally reserved for -one-time runtime cutovers and forensics. - -Selection is read-only and server-side. It uses Kiroku's indexed category, -event-type, and global-position schema to discover only candidate stream names; -each candidate is then hydrated through the public Store effect. The audit -never appends events, calls @verifyAndSnapshot@, or writes snapshots. - -Hand-written services have no spec from which to derive an affected set. They -must supply a conservative set explicitly or choose 'AuditFull'. --} -module Keiro.ReplayAudit ( - AuditMode (..), +-- | Read-only, differential replay audits for aggregate event streams. +-- +-- Routine deploys should first consume @keiro-dsl diff@'s replay-impact verdict: +-- a replay-neutral deploy touches no data, while an affected verdict supplies the +-- event types for 'AuditTargeted'. 'AuditFull' is intentionally reserved for +-- one-time runtime cutovers and forensics. +-- +-- Selection is read-only and server-side. It uses Kiroku's indexed category, +-- event-type, and global-position schema to discover only candidate stream names; +-- each candidate is then hydrated through the public Store effect. The audit +-- never appends events, calls @verifyAndSnapshot@, or writes snapshots. +-- +-- Hand-written services have no spec from which to derive an affected set. They +-- must supply a conservative set explicitly or choose 'AuditFull'. +module Keiro.ReplayAudit + ( AuditMode (..), AffectedSet (..), AuditBudget (..), defaultAuditBudget, @@ -31,7 +30,8 @@ auditTargets, renderAuditReport, auditExitCode, -) where + ) +where import Contravariant.Extras (contrazip3, contrazip5) import Data.Int (Int32) @@ -48,14 +48,14 @@ import Hasql.Encoders qualified as E import Hasql.Statement (Statement, preparable) import Keiki.Core (BoolAlg, RegFile) -import Keiro.Command ( - CommandError, +import Keiro.Command + ( CommandError, Hydrated (..), RunCommandOptions, defaultRunCommandOptions, hydrateFull, hydrateSeeded, - ) + ) import Keiro.EventStream (EventStream, StateCodec) import Keiro.EventStream.Validate (ValidatedEventStream, unvalidated) import Keiro.Prelude @@ -65,486 +65,485 @@ import Kiroku.Store.Effect (Store) import Kiroku.Store.Read (lookupStreamNames) import Kiroku.Store.Transaction (runTransaction) -import Kiroku.Store.Types ( - CategoryName (..), +import Kiroku.Store.Types + ( CategoryName (..), EventType (..), GlobalPosition (..), StreamId (..), StreamName (..), StreamVersion, - ) + ) import Kiroku.Store.Types qualified as StoreTypes import "hasql-transaction" Hasql.Transaction qualified as Tx import Prelude qualified -- | Which streams to inspect. data AuditMode - = AuditFull - | AuditTargeted !AffectedSet - deriving stock (Eq, Show, Generic) + = AuditFull + | AuditTargeted !AffectedSet + deriving stock (Eq, Show, Generic) -- | Conservative stored-data surface emitted by the DSL replay-impact diff. data AffectedSet = AffectedSet - { affectedEventTypes :: !(Set EventType) - , includeSnapshotStreams :: !Bool - } - deriving stock (Eq, Show, Generic) - -{- | Per-run cost and resume controls. + { affectedEventTypes :: !(Set EventType), + includeSnapshotStreams :: !Bool + } + deriving stock (Eq, Show, Generic) -The checkpoint is the maximum global position of the last audited stream at -the selection snapshot. Re-running with that checkpoint selects only streams -whose latest event lies after it. A category that receives new events during -or after a run may intentionally cause a previously checked stream to be -selected again: its durable history changed and warrants another verdict. --} +-- | Per-run cost and resume controls. +-- +-- The checkpoint is the maximum global position of the last audited stream at +-- the selection snapshot. Re-running with that checkpoint selects only streams +-- whose latest event lies after it. A category that receives new events during +-- or after a run may intentionally cause a previously checked stream to be +-- selected again: its durable history changed and warrants another verdict. data AuditBudget = AuditBudget - { maxStreams :: !(Maybe Int) - , parallelism :: !Int - , resumeFrom :: !(Maybe GlobalPosition) - } - deriving stock (Eq, Show, Generic) + { maxStreams :: !(Maybe Int), + parallelism :: !Int, + resumeFrom :: !(Maybe GlobalPosition) + } + deriving stock (Eq, Show, Generic) defaultAuditBudget :: AuditBudget defaultAuditBudget = - AuditBudget - { maxStreams = Nothing - , parallelism = 4 - , resumeFrom = Nothing - } + AuditBudget + { maxStreams = Nothing, + parallelism = 4, + resumeFrom = Nothing + } -- | One typed aggregate/category assembly. data AuditTarget phi rs s ci co = AuditTarget - { eventStream :: !(ValidatedEventStream phi rs s ci co) - , category :: !Text - , mkStream :: !(StreamName -> Maybe (Stream (EventStream phi rs s ci co))) - } - deriving stock (Generic) + { eventStream :: !(ValidatedEventStream phi rs s ci co), + category :: !Text, + mkStream :: !(StreamName -> Maybe (Stream (EventStream phi rs s ci co))) + } + deriving stock (Generic) -- | Existential packaging for services with multiple aggregate types. data SomeAuditTarget where - SomeAuditTarget :: - (BoolAlg phi (RegFile rs, ci), Eq co) => - AuditTarget phi rs s ci co -> - SomeAuditTarget + SomeAuditTarget :: + (BoolAlg phi (RegFile rs, ci), Eq co) => + AuditTarget phi rs s ci co -> + SomeAuditTarget -- | Accept a raw store name only when it belongs to the expected category. streamInCategory :: Text -> StreamName -> Maybe (Stream eventStream) streamInCategory expected streamName = - case StoreTypes.categoryName streamName of - CategoryName actual - | actual == expected -> Just (Stream streamName) - _ -> Nothing + case StoreTypes.categoryName streamName of + CategoryName actual + | actual == expected -> Just (Stream streamName) + _ -> Nothing -- | Replay result for one accepted stream name. data AuditOutcome - = ReplayOk - { streamVersion :: !StreamVersion - , digest :: !(Maybe Text) - } - | ReplayFailed - { commandError :: !CommandError - } - | SeedDivergence - { seedVersion :: !StreamVersion - , seededDigest :: !Text - , fullDigest :: !Text - } - deriving stock (Eq, Show, Generic) + = ReplayOk + { streamVersion :: !StreamVersion, + digest :: !(Maybe Text) + } + | ReplayFailed + { commandError :: !CommandError + } + | SeedDivergence + { seedVersion :: !StreamVersion, + seededDigest :: !Text, + fullDigest :: !Text + } + deriving stock (Eq, Show, Generic) data StreamAuditResult = StreamAuditResult - { streamName :: !StreamName - , outcome :: !AuditOutcome - } - deriving stock (Eq, Show, Generic) + { streamName :: !StreamName, + outcome :: !AuditOutcome + } + deriving stock (Eq, Show, Generic) data AuditReport = AuditReport - { targetCategory :: !Text - , mode :: !Text - , results :: ![StreamAuditResult] - , rejectedStreams :: ![StreamName] - , streamsSelected :: !Int - , streamsSkipped :: !Int - , failures :: !Int - , divergences :: !Int - , checkpoint :: !(Maybe GlobalPosition) - } - deriving stock (Eq, Show, Generic) + { targetCategory :: !Text, + mode :: !Text, + results :: ![StreamAuditResult], + rejectedStreams :: ![StreamName], + streamsSelected :: !Int, + streamsSkipped :: !Int, + failures :: !Int, + divergences :: !Int, + checkpoint :: !(Maybe GlobalPosition) + } + deriving stock (Eq, Show, Generic) auditStream :: - forall phi rs s ci co es. - (Store :> es, BoolAlg phi (RegFile rs, ci), Eq co) => - AuditTarget phi rs s ci co -> - Stream (EventStream phi rs s ci co) -> - Eff es AuditOutcome + forall phi rs s ci co es. + (Store :> es, BoolAlg phi (RegFile rs, ci), Eq co) => + AuditTarget phi rs s ci co -> + Stream (EventStream phi rs s ci co) -> + Eff es AuditOutcome auditStream target stream = do - let raw = unvalidated (target ^. #eventStream) - options = defaultRunCommandOptions - hydrateFull options raw stream >>= \case - Left err -> pure (ReplayFailed err) - Right full -> - case raw ^. #stateCodec of - Nothing -> - pure - ReplayOk - { streamVersion = full ^. #streamVersion - , digest = Nothing - } - Just codec -> auditSeed options raw codec full + let raw = unvalidated (target ^. #eventStream) + options = defaultRunCommandOptions + hydrateFull options raw stream >>= \case + Left err -> pure (ReplayFailed err) + Right full -> + case raw ^. #stateCodec of + Nothing -> + pure + ReplayOk + { streamVersion = full ^. #streamVersion, + digest = Nothing + } + Just codec -> auditSeed options raw codec full where auditSeed :: - RunCommandOptions -> - EventStream phi rs s ci co -> - StateCodec (s, RegFile rs) -> - Hydrated rs s -> - Eff es AuditOutcome + RunCommandOptions -> + EventStream phi rs s ci co -> + StateCodec (s, RegFile rs) -> + Hydrated rs s -> + Eff es AuditOutcome auditSeed options raw codec full = do - let name = (raw ^. #resolveStreamName) stream - fullValue = (codec ^. #encode) (full ^. #state, full ^. #registers) - fullBytes = canonicalJsonBytes fullValue - fullHash = replayDigest fullValue - lookupSnapshotSeed name codec >>= \case - SnapshotUnavailable _ -> + let name = (raw ^. #resolveStreamName) stream + fullValue = (codec ^. #encode) (full ^. #state, full ^. #registers) + fullBytes = canonicalJsonBytes fullValue + fullHash = replayDigest fullValue + lookupSnapshotSeed name codec >>= \case + SnapshotUnavailable _ -> + pure + ReplayOk + { streamVersion = full ^. #streamVersion, + digest = Just fullHash + } + SnapshotHit seed -> + hydrateSeeded + options + raw + stream + (seed ^. #state) + (seed ^. #registers) + (seed ^. #streamVersion) + >>= \case + Left err -> pure - ReplayOk - { streamVersion = full ^. #streamVersion - , digest = Just fullHash - } - SnapshotHit seed -> - hydrateSeeded - options - raw - stream - (seed ^. #state) - (seed ^. #registers) - (seed ^. #streamVersion) - >>= \case - Left err -> - pure - SeedDivergence - { seedVersion = seed ^. #streamVersion - , seededDigest = "replay-failed:" <> Text.pack (show err) - , fullDigest = fullHash - } - Right seeded -> - let seededValue = - (codec ^. #encode) - (seeded ^. #state, seeded ^. #registers) - seededHash = replayDigest seededValue - in if canonicalJsonBytes seededValue == fullBytes - then - pure - ReplayOk - { streamVersion = full ^. #streamVersion - , digest = Just fullHash - } - else - pure - SeedDivergence - { seedVersion = seed ^. #streamVersion - , seededDigest = seededHash - , fullDigest = fullHash - } + SeedDivergence + { seedVersion = seed ^. #streamVersion, + seededDigest = "replay-failed:" <> Text.pack (show err), + fullDigest = fullHash + } + Right seeded -> + let seededValue = + (codec ^. #encode) + (seeded ^. #state, seeded ^. #registers) + seededHash = replayDigest seededValue + in if canonicalJsonBytes seededValue == fullBytes + then + pure + ReplayOk + { streamVersion = full ^. #streamVersion, + digest = Just fullHash + } + else + pure + SeedDivergence + { seedVersion = seed ^. #streamVersion, + seededDigest = seededHash, + fullDigest = fullHash + } auditStreams :: - forall phi rs s ci co es. - (IOE :> es, Store :> es, BoolAlg phi (RegFile rs, ci), Eq co) => - AuditMode -> - AuditBudget -> - AuditTarget phi rs s ci co -> - Eff es AuditReport + forall phi rs s ci co es. + (IOE :> es, Store :> es, BoolAlg phi (RegFile rs, ci), Eq co) => + AuditMode -> + AuditBudget -> + AuditTarget phi rs s ci co -> + Eff es AuditReport auditStreams auditMode budget target = do - totalStreams <- categoryStreamCount (target ^. #category) - selectedTotal <- selectedStreamCount auditMode (target ^. #category) - let skipped = - case auditMode of - AuditFull -> 0 - AuditTargeted _ -> Prelude.max 0 (totalStreams Prelude.- selectedTotal) - workerCount = Prelude.max 1 (budget ^. #parallelism) - remaining0 = fmap (Prelude.max 0) (budget ^. #maxStreams) - cursor0 = fromMaybe (GlobalPosition 0) (budget ^. #resumeFrom) - (allResults, rejected, selected, finalCursor) <- - go workerCount remaining0 cursor0 [] [] 0 - let failureCount = - Prelude.length rejected - Prelude.+ Prelude.length - [ () - | StreamAuditResult{outcome = ReplayFailed{}} <- allResults - ] - divergenceCount = - Prelude.length - [ () - | StreamAuditResult{outcome = SeedDivergence{}} <- allResults - ] - pure - AuditReport - { targetCategory = target ^. #category - , mode = case auditMode of AuditFull -> "full"; AuditTargeted _ -> "targeted" - , results = allResults - , rejectedStreams = rejected - , streamsSelected = selected - , streamsSkipped = skipped - , failures = failureCount - , divergences = divergenceCount - , checkpoint = - if selected == 0 - then budget ^. #resumeFrom - else Just finalCursor - } + totalStreams <- categoryStreamCount (target ^. #category) + selectedTotal <- selectedStreamCount auditMode (target ^. #category) + let skipped = + case auditMode of + AuditFull -> 0 + AuditTargeted _ -> Prelude.max 0 (totalStreams Prelude.- selectedTotal) + workerCount = Prelude.max 1 (budget ^. #parallelism) + remaining0 = fmap (Prelude.max 0) (budget ^. #maxStreams) + cursor0 = fromMaybe (GlobalPosition 0) (budget ^. #resumeFrom) + (allResults, rejected, selected, finalCursor) <- + go workerCount remaining0 cursor0 [] [] 0 + let failureCount = + Prelude.length rejected + Prelude.+ Prelude.length + [ () + | StreamAuditResult {outcome = ReplayFailed {}} <- allResults + ] + divergenceCount = + Prelude.length + [ () + | StreamAuditResult {outcome = SeedDivergence {}} <- allResults + ] + pure + AuditReport + { targetCategory = target ^. #category, + mode = case auditMode of AuditFull -> "full"; AuditTargeted _ -> "targeted", + results = allResults, + rejectedStreams = rejected, + streamsSelected = selected, + streamsSkipped = skipped, + failures = failureCount, + divergences = divergenceCount, + checkpoint = + if selected == 0 + then budget ^. #resumeFrom + else Just finalCursor + } where pageSize = 128 go :: - Int -> - Maybe Int -> - GlobalPosition -> - [StreamAuditResult] -> - [StreamName] -> - Int -> - Eff es ([StreamAuditResult], [StreamName], Int, GlobalPosition) + Int -> + Maybe Int -> + GlobalPosition -> + [StreamAuditResult] -> + [StreamName] -> + Int -> + Eff es ([StreamAuditResult], [StreamName], Int, GlobalPosition) go workerCount remaining cursor resultAcc rejectedAcc selectedAcc - | Just 0 <- remaining = - pure - ( Prelude.reverse resultAcc - , Prelude.reverse rejectedAcc - , selectedAcc - , cursor + | Just 0 <- remaining = + pure + ( Prelude.reverse resultAcc, + Prelude.reverse rejectedAcc, + selectedAcc, + cursor + ) + | otherwise = do + let requestSize = + maybe pageSize (Prelude.min pageSize) remaining + page <- selectStreamPage auditMode (target ^. #category) cursor requestSize + if Vector.null page + then + pure + ( Prelude.reverse resultAcc, + Prelude.reverse rejectedAcc, + selectedAcc, + cursor ) - | otherwise = do - let requestSize = - maybe pageSize (Prelude.min pageSize) remaining - page <- selectStreamPage auditMode (target ^. #category) cursor requestSize - if Vector.null page - then - pure - ( Prelude.reverse resultAcc - , Prelude.reverse rejectedAcc - , selectedAcc - , cursor - ) - else do - names <- lookupStreamNames (Prelude.fst <$> Vector.toList page) - let resolved = - [ (streamName, streamValue) - | (streamId, _watermark) <- Vector.toList page - , Just streamName <- [Map.lookup streamId names] - , Just streamValue <- [(target ^. #mkStream) streamName] - ] - acceptedNames = Set.fromList (Prelude.fst <$> resolved) - pageNames = - [ streamName - | (streamId, _watermark) <- Vector.toList page - , Just streamName <- [Map.lookup streamId names] - ] - rejected = - Prelude.filter (`Set.notMember` acceptedNames) pageNames - audited <- - runConcurrent - $ Async.pooledMapConcurrentlyN - workerCount - ( \(name, streamValue) -> - StreamAuditResult name <$> auditStream target streamValue - ) - resolved - let nextCursor = Prelude.snd (Vector.last page) - pageCount = Vector.length page - nextRemaining = (Prelude.- pageCount) <$> remaining - go - workerCount - nextRemaining - nextCursor - (Prelude.reverse audited <> resultAcc) - (Prelude.reverse rejected <> rejectedAcc) - (selectedAcc Prelude.+ pageCount) + else do + names <- lookupStreamNames (Prelude.fst <$> Vector.toList page) + let resolved = + [ (streamName, streamValue) + | (streamId, _watermark) <- Vector.toList page, + Just streamName <- [Map.lookup streamId names], + Just streamValue <- [(target ^. #mkStream) streamName] + ] + acceptedNames = Set.fromList (Prelude.fst <$> resolved) + pageNames = + [ streamName + | (streamId, _watermark) <- Vector.toList page, + Just streamName <- [Map.lookup streamId names] + ] + rejected = + Prelude.filter (`Set.notMember` acceptedNames) pageNames + audited <- + runConcurrent + $ Async.pooledMapConcurrentlyN + workerCount + ( \(name, streamValue) -> + StreamAuditResult name <$> auditStream target streamValue + ) + resolved + let nextCursor = Prelude.snd (Vector.last page) + pageCount = Vector.length page + nextRemaining = (Prelude.- pageCount) <$> remaining + go + workerCount + nextRemaining + nextCursor + (Prelude.reverse audited <> resultAcc) + (Prelude.reverse rejected <> rejectedAcc) + (selectedAcc Prelude.+ pageCount) auditTargets :: - (IOE :> es, Store :> es) => - AuditMode -> - AuditBudget -> - [SomeAuditTarget] -> - Eff es [AuditReport] + (IOE :> es, Store :> es) => + AuditMode -> + AuditBudget -> + [SomeAuditTarget] -> + Eff es [AuditReport] auditTargets auditMode budget = - traverse $ \(SomeAuditTarget target) -> auditStreams auditMode budget target + traverse $ \(SomeAuditTarget target) -> auditStreams auditMode budget target renderAuditReport :: AuditReport -> Text renderAuditReport report = - Text.intercalate - " " - [ "replay-audit" - , "category=" <> report ^. #targetCategory - , "mode=" <> report ^. #mode - , "selected=" <> textShow (report ^. #streamsSelected) - , "skipped=" <> textShow (report ^. #streamsSkipped) - , "failures=" <> textShow (report ^. #failures) - , "divergences=" <> textShow (report ^. #divergences) - , "checkpoint=" <> maybe "none" textShow (report ^. #checkpoint) - ] + Text.intercalate + " " + [ "replay-audit", + "category=" <> report ^. #targetCategory, + "mode=" <> report ^. #mode, + "selected=" <> textShow (report ^. #streamsSelected), + "skipped=" <> textShow (report ^. #streamsSkipped), + "failures=" <> textShow (report ^. #failures), + "divergences=" <> textShow (report ^. #divergences), + "checkpoint=" <> maybe "none" textShow (report ^. #checkpoint) + ] where textShow :: (Show a) => a -> Text textShow = Text.pack . show auditExitCode :: [AuditReport] -> Int auditExitCode reports - | Prelude.any - (\report -> report ^. #failures > 0 Prelude.|| report ^. #divergences > 0) - reports = - 1 - | otherwise = 0 + | Prelude.any + (\report -> report ^. #failures > 0 Prelude.|| report ^. #divergences > 0) + reports = + 1 + | otherwise = 0 -- Selection ----------------------------------------------------------------- categoryStreamCount :: (Store :> es) => Text -> Eff es Int categoryStreamCount category = - Prelude.fromIntegral <$> runTransaction (Tx.statement category categoryStreamCountStmt) + Prelude.fromIntegral <$> runTransaction (Tx.statement category categoryStreamCountStmt) selectedStreamCount :: (Store :> es) => AuditMode -> Text -> Eff es Int selectedStreamCount auditMode category = - case auditMode of - AuditFull -> categoryStreamCount category - AuditTargeted affected -> - Prelude.fromIntegral - <$> runTransaction - ( Tx.statement - (category, eventTypeTexts affected, affected ^. #includeSnapshotStreams) - targetedStreamCountStmt - ) + case auditMode of + AuditFull -> categoryStreamCount category + AuditTargeted affected -> + Prelude.fromIntegral + <$> runTransaction + ( Tx.statement + (category, eventTypeTexts affected, affected ^. #includeSnapshotStreams) + targetedStreamCountStmt + ) selectStreamPage :: - (Store :> es) => - AuditMode -> - Text -> - GlobalPosition -> - Int -> - Eff es (Vector (StreamId, GlobalPosition)) + (Store :> es) => + AuditMode -> + Text -> + GlobalPosition -> + Int -> + Eff es (Vector (StreamId, GlobalPosition)) selectStreamPage auditMode category (GlobalPosition cursor) limit = - case auditMode of - AuditFull -> - runTransaction - $ Tx.statement - (category, cursor, Prelude.fromIntegral limit) - fullStreamPageStmt - AuditTargeted affected -> - runTransaction - $ Tx.statement - ( category - , eventTypeTexts affected - , affected ^. #includeSnapshotStreams - , cursor - , Prelude.fromIntegral limit - ) - targetedStreamPageStmt + case auditMode of + AuditFull -> + runTransaction + $ Tx.statement + (category, cursor, Prelude.fromIntegral limit) + fullStreamPageStmt + AuditTargeted affected -> + runTransaction + $ Tx.statement + ( category, + eventTypeTexts affected, + affected ^. #includeSnapshotStreams, + cursor, + Prelude.fromIntegral limit + ) + targetedStreamPageStmt eventTypeTexts :: AffectedSet -> Vector Text eventTypeTexts affected = - Vector.fromList - [ text - | EventType text <- Set.toAscList (affected ^. #affectedEventTypes) - ] + Vector.fromList + [ text + | EventType text <- Set.toAscList (affected ^. #affectedEventTypes) + ] categoryStreamCountStmt :: Statement Text Int64 categoryStreamCountStmt = - preparable - """ - SELECT count(*) - FROM kiroku.streams - WHERE category = $1 - AND stream_version > 0 - """ - (E.param (E.nonNullable E.text)) - (D.singleRow (D.column (D.nonNullable D.int8))) + preparable + """ + SELECT count(*) + FROM kiroku.streams + WHERE category = $1 + AND stream_version > 0 + """ + (E.param (E.nonNullable E.text)) + (D.singleRow (D.column (D.nonNullable D.int8))) fullStreamPageStmt :: Statement (Text, Int64, Int32) (Vector (StreamId, GlobalPosition)) fullStreamPageStmt = - preparable - """ - SELECT s.stream_id, max(all_events.stream_version) AS watermark - FROM kiroku.streams s - JOIN kiroku.stream_events all_events - ON all_events.stream_id = 0 - AND all_events.original_stream_id = s.stream_id - WHERE s.category = $1 - GROUP BY s.stream_id - HAVING max(all_events.stream_version) > $2 - ORDER BY watermark ASC - LIMIT $3 - """ - ( contrazip3 - (E.param (E.nonNullable E.text)) - (E.param (E.nonNullable E.int8)) - (E.param (E.nonNullable E.int4)) - ) - streamPageDecoder + preparable + """ + SELECT s.stream_id, max(all_events.stream_version) AS watermark + FROM kiroku.streams s + JOIN kiroku.stream_events all_events + ON all_events.stream_id = 0 + AND all_events.original_stream_id = s.stream_id + WHERE s.category = $1 + GROUP BY s.stream_id + HAVING max(all_events.stream_version) > $2 + ORDER BY watermark ASC + LIMIT $3 + """ + ( contrazip3 + (E.param (E.nonNullable E.text)) + (E.param (E.nonNullable E.int8)) + (E.param (E.nonNullable E.int4)) + ) + streamPageDecoder targetedStreamCountStmt :: Statement (Text, Vector Text, Bool) Int64 targetedStreamCountStmt = - preparable - (targetedSelectionCte <> "SELECT count(*) FROM selected") - targetedSelectionEncoder - (D.singleRow (D.column (D.nonNullable D.int8))) + preparable + (targetedSelectionCte <> "SELECT count(*) FROM selected") + targetedSelectionEncoder + (D.singleRow (D.column (D.nonNullable D.int8))) targetedStreamPageStmt :: - Statement - (Text, Vector Text, Bool, Int64, Int32) - (Vector (StreamId, GlobalPosition)) + Statement + (Text, Vector Text, Bool, Int64, Int32) + (Vector (StreamId, GlobalPosition)) targetedStreamPageStmt = - preparable - ( targetedSelectionCte - <> """ - SELECT stream_id, watermark - FROM selected - WHERE watermark > $4 - ORDER BY watermark ASC - LIMIT $5 - """ - ) - ( contrazip5 - (E.param (E.nonNullable E.text)) - (E.param (E.nonNullable (E.foldableArray (E.nonNullable E.text)))) - (E.param (E.nonNullable E.bool)) - (E.param (E.nonNullable E.int8)) - (E.param (E.nonNullable E.int4)) - ) - streamPageDecoder - -targetedSelectionEncoder :: E.Params (Text, Vector Text, Bool) -targetedSelectionEncoder = - contrazip3 + preparable + ( targetedSelectionCte + <> """ + SELECT stream_id, watermark + FROM selected + WHERE watermark > $4 + ORDER BY watermark ASC + LIMIT $5 + """ + ) + ( contrazip5 (E.param (E.nonNullable E.text)) (E.param (E.nonNullable (E.foldableArray (E.nonNullable E.text)))) (E.param (E.nonNullable E.bool)) + (E.param (E.nonNullable E.int8)) + (E.param (E.nonNullable E.int4)) + ) + streamPageDecoder +targetedSelectionEncoder :: E.Params (Text, Vector Text, Bool) +targetedSelectionEncoder = + contrazip3 + (E.param (E.nonNullable E.text)) + (E.param (E.nonNullable (E.foldableArray (E.nonNullable E.text)))) + (E.param (E.nonNullable E.bool)) + targetedSelectionCte :: Text targetedSelectionCte = - """ - WITH candidate_streams AS ( - SELECT DISTINCT s.stream_id - FROM kiroku.streams s - JOIN kiroku.stream_events source_events - ON source_events.stream_id = 0 - AND source_events.original_stream_id = s.stream_id - JOIN kiroku.events e ON e.event_id = source_events.event_id - WHERE s.category = $1 - AND e.event_type = ANY($2::text[]) - UNION - SELECT s.stream_id - FROM kiroku.streams s - JOIN keiro.keiro_snapshots snapshots ON snapshots.stream_id = s.stream_id - WHERE $3 - AND s.category = $1 - ), - selected AS ( - SELECT candidates.stream_id, max(all_events.stream_version) AS watermark - FROM candidate_streams candidates - JOIN kiroku.stream_events all_events - ON all_events.stream_id = 0 - AND all_events.original_stream_id = candidates.stream_id - GROUP BY candidates.stream_id - ) - """ + """ + WITH candidate_streams AS ( + SELECT DISTINCT s.stream_id + FROM kiroku.streams s + JOIN kiroku.stream_events source_events + ON source_events.stream_id = 0 + AND source_events.original_stream_id = s.stream_id + JOIN kiroku.events e ON e.event_id = source_events.event_id + WHERE s.category = $1 + AND e.event_type = ANY($2::text[]) + UNION + SELECT s.stream_id + FROM kiroku.streams s + JOIN keiro.keiro_snapshots snapshots ON snapshots.stream_id = s.stream_id + WHERE $3 + AND s.category = $1 + ), + selected AS ( + SELECT candidates.stream_id, max(all_events.stream_version) AS watermark + FROM candidate_streams candidates + JOIN kiroku.stream_events all_events + ON all_events.stream_id = 0 + AND all_events.original_stream_id = candidates.stream_id + GROUP BY candidates.stream_id + ) + """ streamPageDecoder :: D.Result (Vector (StreamId, GlobalPosition)) streamPageDecoder = - D.rowVector - $ (,) - <$> (StreamId <$> D.column (D.nonNullable D.int8)) - <*> (GlobalPosition <$> D.column (D.nonNullable D.int8)) + D.rowVector + $ (,) + <$> (StreamId <$> D.column (D.nonNullable D.int8)) + <*> (GlobalPosition <$> D.column (D.nonNullable D.int8)) diff --git a/src/Keiro/ReplayDigest.hs b/src/Keiro/ReplayDigest.hs --- a/src/Keiro/ReplayDigest.hs +++ b/src/Keiro/ReplayDigest.hs @@ -1,15 +1,15 @@ -{- | Stable canonical encodings and SHA-256 digests for replay comparisons. - -Canonicalization is Aeson's RFC 8785 implementation. Hashing is the maintained -@cryptohash-sha256@ implementation of FIPS 180-4, and hexadecimal rendering is -@base16-bytestring@'s RFC 4648 encoder. Correctness comparisons still use the -canonical bytes directly; the digest is their compact operator-facing -identifier. --} -module Keiro.ReplayDigest ( - canonicalJsonBytes, +-- | Stable canonical encodings and SHA-256 digests for replay comparisons. +-- +-- Canonicalization is Aeson's RFC 8785 implementation. Hashing is the maintained +-- @cryptohash-sha256@ implementation of FIPS 180-4, and hexadecimal rendering is +-- @base16-bytestring@'s RFC 4648 encoder. Correctness comparisons still use the +-- canonical bytes directly; the digest is their compact operator-facing +-- identifier. +module Keiro.ReplayDigest + ( canonicalJsonBytes, replayDigest, -) where + ) +where import Crypto.Hash.SHA256 qualified as SHA256 import Data.Aeson.RFC8785 qualified as RFC8785 @@ -26,7 +26,7 @@ -- | SHA-256 over RFC 8785 canonical JSON, rendered as lower-case hexadecimal. replayDigest :: Value -> Text replayDigest = - Text.decodeUtf8 - . Base16.encode - . SHA256.hash - . canonicalJsonBytes + Text.decodeUtf8 + . Base16.encode + . SHA256.hash + . canonicalJsonBytes diff --git a/src/Keiro/Router.hs b/src/Keiro/Router.hs --- a/src/Keiro/Router.hs +++ b/src/Keiro/Router.hs @@ -1,34 +1,33 @@ -{- | Stateless, content-based routing of events to commands. - -A 'Router' is the stateless sibling of -'Keiro.ProcessManager.ProcessManager': for each incoming event it resolves -a data-dependent set of target streams /effectfully/ (typically via a -read-model query) and dispatches one command to each. Dispatch is -idempotent per resolved target identity: every command is appended under a -target-name-keyed deterministic id, and store-level duplicate rejections are -confirmed against that target before becoming a benign -'PMCommandDuplicate'. Redelivery therefore deduplicates every target resolved -again, regardless of target order. Because resolution is effectful, the target -set may drift between attempts; dispatches accumulate as the union of those -attempts, so callers that require one exact set must keep resolution stable for -a source event. - -Use 'runRouterOnce' to dispatch a single event, or 'runRouterWorker' to run -the router as a live subscription draining a Shibuya adapter. Its retry and -source-event dead-letter contract is the same bounded Kiroku contract described -by "Keiro.ProcessManager": five total deliveries by default, followed by a -@kiroku.dead_letters@ write and atomic checkpoint advance. - -A router's 'key' can join events from different source streams just as a -process manager's @correlate@ function can. The same ordering rule applies: -same-stream order is preserved, but different streams have no relative -business-order guarantee and may run concurrently under sharding. Keep routed -logic order-insensitive; see "Keiro.ProcessManager" for the worked example. -Each resolved target command (with its inline projections) commits in its own -transaction, so fan-out is idempotent rather than all-target atomic. --} -module Keiro.Router ( - -- * Definition +-- | Stateless, content-based routing of events to commands. +-- +-- A 'Router' is the stateless sibling of +-- 'Keiro.ProcessManager.ProcessManager': for each incoming event it resolves +-- a data-dependent set of target streams /effectfully/ (typically via a +-- read-model query) and dispatches one command to each. Dispatch is +-- idempotent per resolved target identity: every command is appended under a +-- target-name-keyed deterministic id, and store-level duplicate rejections are +-- confirmed against that target before becoming a benign +-- 'PMCommandDuplicate'. Redelivery therefore deduplicates every target resolved +-- again, regardless of target order. Because resolution is effectful, the target +-- set may drift between attempts; dispatches accumulate as the union of those +-- attempts, so callers that require one exact set must keep resolution stable for +-- a source event. +-- +-- Use 'runRouterOnce' to dispatch a single event, or 'runRouterWorker' to run +-- the router as a live subscription draining a Shibuya adapter. Its retry and +-- source-event dead-letter contract is the same bounded Kiroku contract described +-- by "Keiro.ProcessManager": five total deliveries by default, followed by a +-- @kiroku.dead_letters@ write and atomic checkpoint advance. +-- +-- A router's 'key' can join events from different source streams just as a +-- process manager's @correlate@ function can. The same ordering rule applies: +-- same-stream order is preserved, but different streams have no relative +-- business-order guarantee and may run concurrently under sharding. Keep routed +-- logic order-insensitive; see "Keiro.ProcessManager" for the worked example. +-- Each resolved target command (with its inline projections) commits in its own +-- transaction, so fan-out is idempotent rather than all-target atomic. +module Keiro.Router + ( -- * Definition Router (..), RouterResult (..), @@ -39,7 +38,7 @@ runRouterOnce, runRouterWorkerWith, runRouterWorker, -) + ) where import Data.ByteString qualified as ByteString @@ -60,8 +59,8 @@ import Keiro.EventStream (EventStream) import Keiro.EventStream.Validate (ValidatedEventStream, unvalidated) import Keiro.Prelude -import Keiro.ProcessManager ( - DispatchFailure (..), +import Keiro.ProcessManager + ( DispatchFailure (..), PMCommand (..), PMCommandResult (..), PoisonPolicy (..), @@ -72,7 +71,7 @@ defaultWorkerOptions, deterministicCommandId, eventAlreadyIn, - ) + ) import Keiro.Projection (InlineProjection, runCommandWithProjections) import Keiro.Stream (Stream) import Keiro.Telemetry (recordDispatchDuplicate, recordDispatchFailed, recordDispatchPoison) @@ -89,337 +88,330 @@ import Streamly.Data.Stream qualified as Streamly import Prelude (filter, fromIntegral, length, snd, zip, (+)) -{- | A stateless, content-based router (in the Enterprise Integration Patterns -sense): for each incoming event it resolves a data-dependent set of target -streams /effectfully/ and dispatches one command to each. - -This is the stateless counterpart of 'Keiro.ProcessManager.ProcessManager'. It -has no manager state stream, no @correlate@, and no self-directed command. Its -sole new capability over the process manager is that target resolution runs in -@Eff es@ — typically a read-model query via 'Keiro.ReadModel.runQuery' — so the -fan-out set can be /looked up/ rather than computed purely from the event. - -Dispatch is idempotent by construction: each target command is appended under a -deterministic identifier derived from @(name, key input, source event id, -resolved target stream name, occurrence)@ (see -'deterministicRouterCommandId'), pre-checked with 'eventAlreadyIn', and the -store's @DuplicateEvent@ rejection is confirmed against the target stream -before it is treated as benign. A redelivery deduplicates every target it -resolves again even if target order or membership changed. A target resolved -only on an earlier attempt keeps its immutable dispatch, and a newly resolved -target is dispatched on the later attempt; the cumulative set is therefore the -union of attempt outputs. Keep 'resolve' stable for a source event when the -exact recipient set matters. - -Each dispatch also runs 'targetProjections' for the target aggregate in the same -append transaction. The function receives the concrete target stream so callers can -build projections closed over stream-local keys. Return @[]@ to preserve -append-only dispatch. --} +-- | A stateless, content-based router (in the Enterprise Integration Patterns +-- sense): for each incoming event it resolves a data-dependent set of target +-- streams /effectfully/ and dispatches one command to each. +-- +-- This is the stateless counterpart of 'Keiro.ProcessManager.ProcessManager'. It +-- has no manager state stream, no @correlate@, and no self-directed command. Its +-- sole new capability over the process manager is that target resolution runs in +-- @Eff es@ — typically a read-model query via 'Keiro.ReadModel.runQuery' — so the +-- fan-out set can be /looked up/ rather than computed purely from the event. +-- +-- Dispatch is idempotent by construction: each target command is appended under a +-- deterministic identifier derived from @(name, key input, source event id, +-- resolved target stream name, occurrence)@ (see +-- 'deterministicRouterCommandId'), pre-checked with 'eventAlreadyIn', and the +-- store's @DuplicateEvent@ rejection is confirmed against the target stream +-- before it is treated as benign. A redelivery deduplicates every target it +-- resolves again even if target order or membership changed. A target resolved +-- only on an earlier attempt keeps its immutable dispatch, and a newly resolved +-- target is dispatched on the later attempt; the cumulative set is therefore the +-- union of attempt outputs. Keep 'resolve' stable for a source event when the +-- exact recipient set matters. +-- +-- Each dispatch also runs 'targetProjections' for the target aggregate in the same +-- append transaction. The function receives the concrete target stream so callers can +-- build projections closed over stream-local keys. Return @[]@ to preserve +-- append-only dispatch. data Router input targetPhi targetRs targetState targetCi targetCo es = Router - { name :: !Text - -- ^ Stable identifier; part of every dispatched command's deterministic id. - , key :: !(input -> Text) - -- ^ Correlation string for the source event (e.g. the transaction id). - , resolve :: !(input -> Eff es [PMCommand targetCi]) - {- ^ The effectful seam: compute the data-dependent target set, typically - @runQuery readModel q@. - -} - , targetEventStream :: !(ValidatedEventStream targetPhi targetRs targetState targetCi targetCo) - -- ^ The aggregate every resolved command is dispatched to. - , targetProjections :: !(Stream targetCi -> [InlineProjection targetCo]) - {- ^ Inline projections for the target aggregate, run in the same transaction - as each dispatched command's append. Return @[]@ for append-only dispatch. - -} - } - deriving stock (Generic) - -{- | The outcome of a single 'runRouterOnce' invocation: one -'PMCommandResult' per resolved target, in resolution order. + { -- | Stable identifier; part of every dispatched command's deterministic id. + name :: !Text, + -- | Correlation string for the source event (e.g. the transaction id). + key :: !(input -> Text), + -- | The effectful seam: compute the data-dependent target set, typically + -- @runQuery readModel q@. + resolve :: !(input -> Eff es [PMCommand targetCi]), + -- | The aggregate every resolved command is dispatched to. + targetEventStream :: !(ValidatedEventStream targetPhi targetRs targetState targetCi targetCo), + -- | Inline projections for the target aggregate, run in the same transaction + -- as each dispatched command's append. Return @[]@ for append-only dispatch. + targetProjections :: !(Stream targetCi -> [InlineProjection targetCo]) + } + deriving stock (Generic) -Unlike 'Keiro.ProcessManager.ProcessManagerResult' there is no manager-state -result, because a router has no state stream. A failed dispatch surfaces as a -'PMCommandFailed' element rather than an outer 'Either'. --} +-- | The outcome of a single 'runRouterOnce' invocation: one +-- 'PMCommandResult' per resolved target, in resolution order. +-- +-- Unlike 'Keiro.ProcessManager.ProcessManagerResult' there is no manager-state +-- result, because a router has no state stream. A failed dispatch surfaces as a +-- 'PMCommandFailed' element rather than an outer 'Either'. newtype RouterResult target = RouterResult - { commandResults :: [PMCommandResult target] - } - deriving stock (Generic, Eq, Show) - -{- | Derive a stable, collision-resistant 'EventId' for a router dispatch from -@(router name, key input, source event id, resolved target stream name, -occurrence)@ via a v5 UUID. - -Unlike 'Keiro.ProcessManager.deterministicCommandId' (which the process manager -still uses, soundly, because its command list is a pure function of the input), -the router keys the id by the target's identity rather than its position in the -resolved list: 'resolve' is effectful, so a redelivery may see the same targets -in a different order or a drifted set, and a positional id would then point at -the wrong target. The @occurrence@ is the index among commands in the same -resolve batch that address the same target stream (0 for the first), so -resolving the same target twice in one batch still yields distinct ids. + { commandResults :: [PMCommandResult target] + } + deriving stock (Generic, Eq, Show) -The v5 name encodes every text field as length-prefixed UTF-8. This avoids both -delimiter ambiguity when names contain colons and character truncation for -non-ASCII names. --} +-- | Derive a stable, collision-resistant 'EventId' for a router dispatch from +-- @(router name, key input, source event id, resolved target stream name, +-- occurrence)@ via a v5 UUID. +-- +-- Unlike 'Keiro.ProcessManager.deterministicCommandId' (which the process manager +-- still uses, soundly, because its command list is a pure function of the input), +-- the router keys the id by the target's identity rather than its position in the +-- resolved list: 'resolve' is effectful, so a redelivery may see the same targets +-- in a different order or a drifted set, and a positional id would then point at +-- the wrong target. The @occurrence@ is the index among commands in the same +-- resolve batch that address the same target stream (0 for the first), so +-- resolving the same target twice in one batch still yields distinct ids. +-- +-- The v5 name encodes every text field as length-prefixed UTF-8. This avoids both +-- delimiter ambiguity when names contain colons and character truncation for +-- non-ASCII names. deterministicRouterCommandId :: Text -> Text -> EventId -> StreamName -> Int -> EventId deterministicRouterCommandId routerName correlationId sourceEventId targetStreamName occurrence = - EventId - $ UUID.V5.generateNamed UUID.V5.namespaceURL - $ ByteString.unpack - $ ByteString.concat - $ fmap - encodeField - [ "keiro" - , "router" - , routerName - , correlationId - , UUID.toText (coerce sourceEventId) - , coerce targetStreamName - , Text.pack (show occurrence) - ] + EventId + $ UUID.V5.generateNamed UUID.V5.namespaceURL + $ ByteString.unpack + $ ByteString.concat + $ fmap + encodeField + [ "keiro", + "router", + routerName, + correlationId, + UUID.toText (coerce sourceEventId), + coerce targetStreamName, + Text.pack (show occurrence) + ] where encodeField field = - let bytes = Text.Encoding.encodeUtf8 field - in ByteString.concat - [ ByteString.Char8.pack (show (ByteString.length bytes)) - , ByteString.singleton 58 - , bytes - ] - -{- | Resolve the targets for one source event, then dispatch one command per -target with crash-safe, target-identity idempotency. - -Unlike 'Keiro.ProcessManager.runProcessManagerOnce', whose pure command list -can safely use positional ids, a router derives each id from the resolved -target stream name and its same-stream occurrence. It skips ids already in the -target stream, otherwise runs 'Keiro.Projection.runCommandWithProjections', and -folds a @DuplicateEvent@ rejection only after confirming the attempted id is in -that target stream. + let bytes = Text.Encoding.encodeUtf8 field + in ByteString.concat + [ ByteString.Char8.pack (show (ByteString.length bytes)), + ByteString.singleton 58, + bytes + ] -Returns 'RouterResult' directly (no outer @Either CommandError@) because — unlike -the process manager — there is no manager-state append that can fail before -dispatch. --} +-- | Resolve the targets for one source event, then dispatch one command per +-- target with crash-safe, target-identity idempotency. +-- +-- Unlike 'Keiro.ProcessManager.runProcessManagerOnce', whose pure command list +-- can safely use positional ids, a router derives each id from the resolved +-- target stream name and its same-stream occurrence. It skips ids already in the +-- target stream, otherwise runs 'Keiro.Projection.runCommandWithProjections', and +-- folds a @DuplicateEvent@ rejection only after confirming the attempted id is in +-- that target stream. +-- +-- Returns 'RouterResult' directly (no outer @Either CommandError@) because — unlike +-- the process manager — there is no manager-state append that can fail before +-- dispatch. runRouterOnce :: - forall input targetPhi targetRs targetState targetCi targetCo es. - ( HasCallStack - , IOE :> es - , Store :> es - , Error StoreError :> es - , KirokuStoreResource :> es - , BoolAlg targetPhi (RegFile targetRs, targetCi) - , Eq targetCo - ) => - RunCommandOptions -> - Router input targetPhi targetRs targetState targetCi targetCo es -> - RecordedEvent -> - input -> - Eff es (RouterResult (EventStream targetPhi targetRs targetState targetCi targetCo)) + forall input targetPhi targetRs targetState targetCi targetCo es. + ( HasCallStack, + IOE :> es, + Store :> es, + Error StoreError :> es, + KirokuStoreResource :> es, + BoolAlg targetPhi (RegFile targetRs, targetCi), + Eq targetCo + ) => + RunCommandOptions -> + Router input targetPhi targetRs targetState targetCi targetCo es -> + RecordedEvent -> + input -> + Eff es (RouterResult (EventStream targetPhi targetRs targetState targetCi targetCo)) runRouterOnce options router sourceEvent input = do - let correlationId = (router ^. #key) input - commands <- (router ^. #resolve) input - let named = - [ (streamNameOf command, command) - | command <- commands - ] - annotated = snd (mapAccumL occurrenceStep Map.empty (zip [0 ..] named)) - occurrenceStep seen (legacyIndex, (targetStreamName, command)) = - let occurrence = Map.findWithDefault 0 targetStreamName seen - in ( Map.insert targetStreamName (occurrence + 1) seen - , (legacyIndex, occurrence, targetStreamName, command) - ) - results <- - traverse - (dispatchCommand correlationId (sourceEvent ^. #eventId)) - annotated - pure (RouterResult results) + let correlationId = (router ^. #key) input + commands <- (router ^. #resolve) input + let named = + [ (streamNameOf command, command) + | command <- commands + ] + annotated = snd (mapAccumL occurrenceStep Map.empty (zip [0 ..] named)) + occurrenceStep seen (legacyIndex, (targetStreamName, command)) = + let occurrence = Map.findWithDefault 0 targetStreamName seen + in ( Map.insert targetStreamName (occurrence + 1) seen, + (legacyIndex, occurrence, targetStreamName, command) + ) + results <- + traverse + (dispatchCommand correlationId (sourceEvent ^. #eventId)) + annotated + pure (RouterResult results) where streamNameOf command = - ((unvalidated (router ^. #targetEventStream)) ^. #resolveStreamName) - (retarget (command ^. #target)) + ((unvalidated (router ^. #targetEventStream)) ^. #resolveStreamName) + (retarget (command ^. #target)) dispatchCommand correlationId sourceEventId (legacyIndex, occurrence, targetStreamName, command) = do - let commandId = - deterministicRouterCommandId - (router ^. #name) - correlationId - sourceEventId - targetStreamName - occurrence - -- Transition: dispatches written by keiro versions that derived - -- positional ids must still dedup across the upgrade. Remove in a - -- later release after the compatibility window closes. - legacyCommandId = - deterministicCommandId - (router ^. #name) - correlationId - sourceEventId - legacyIndex - targetOptions = options & #eventIds .~ [commandId] - targetEventStream = router ^. #targetEventStream - targetStream = retarget (command ^. #target) - commandAlreadyProcessed <- eventAlreadyIn options targetStreamName commandId - legacyAlreadyProcessed <- - if commandAlreadyProcessed - then pure False - else eventAlreadyIn options targetStreamName legacyCommandId + let commandId = + deterministicRouterCommandId + (router ^. #name) + correlationId + sourceEventId + targetStreamName + occurrence + -- Transition: dispatches written by keiro versions that derived + -- positional ids must still dedup across the upgrade. Remove in a + -- later release after the compatibility window closes. + legacyCommandId = + deterministicCommandId + (router ^. #name) + correlationId + sourceEventId + legacyIndex + targetOptions = options & #eventIds .~ [commandId] + targetEventStream = router ^. #targetEventStream + targetStream = retarget (command ^. #target) + commandAlreadyProcessed <- eventAlreadyIn options targetStreamName commandId + legacyAlreadyProcessed <- if commandAlreadyProcessed - then pure (PMCommandDuplicate commandId) - else - if legacyAlreadyProcessed - then pure (PMCommandDuplicate legacyCommandId) - else do - outcome <- - runCommandWithProjections - targetOptions - targetEventStream - targetStream - (command ^. #command) - ((router ^. #targetProjections) (command ^. #target)) - case outcome of - Right result -> pure (PMCommandAppended result) - Left err -> do - benign <- confirmBenignDuplicate targetStreamName commandId err - pure $ if benign then PMCommandDuplicate commandId else PMCommandFailed targetStreamName err + then pure False + else eventAlreadyIn options targetStreamName legacyCommandId + if commandAlreadyProcessed + then pure (PMCommandDuplicate commandId) + else + if legacyAlreadyProcessed + then pure (PMCommandDuplicate legacyCommandId) + else do + outcome <- + runCommandWithProjections + targetOptions + targetEventStream + targetStream + (command ^. #command) + ((router ^. #targetProjections) (command ^. #target)) + case outcome of + Right result -> pure (PMCommandAppended result) + Left err -> do + benign <- confirmBenignDuplicate targetStreamName commandId err + pure $ if benign then PMCommandDuplicate commandId else PMCommandFailed targetStreamName err retarget :: Stream targetCi -> Stream (EventStream targetPhi targetRs targetState targetCi targetCo) retarget = coerce -{- | Run a 'Router' as a live subscription over a Shibuya 'Adapter'. - -Mirrors 'Keiro.ProcessManager.runProcessManagerWorker': it drains the adapter's -message stream, decoding each message to a @(RecordedEvent, input)@ pair and -dispatching it through 'runRouterOnce'. - -Ack policy (see this plan's Decision Log): - - * a message that fails to decode follows the configured 'PoisonPolicy' - (default: 'AckHalt' @HaltFatal@); - * otherwise, after dispatch, if every 'PMCommandResult' is - 'PMCommandAppended' or 'PMCommandDuplicate' the message finalizes 'AckOk'; - * if any dispatch is 'PMCommandFailed', transient failures finalize - 'AckRetry', systemic deterministic failures finalize @AckHalt - (HaltFatal …)@, and rejection-class failures follow - 'RejectedCommandPolicy'. - -Benign domain rejections (a target aggregate refusing a "check" command because -no edge matches) must be modeled as /total/ transitions in the keiki transducer -(an ε-complement self-loop) so they never surface as 'PMCommandFailed' and -therefore never wedge the worker. When the rejection is genuinely -data-dependent, 'RejectedDeadLetter' persists a queryable -"Keiro.DeadLetter.DispatchDeadLetter" and acknowledges the source event; -'RejectedSkip' acknowledges and records only the metric. 'RejectedHalt' remains -the default. - -The worker invokes each ingested message's 'Shibuya.Core.AckHandle.AckHandle' -@finalize@ exactly once with the decision, so the decision reaches the adapter. -Use 'runRouterWorkerWith' to override poison-message handling, rejected-command -handling, transient retry delay, or dispatch metrics. On a Kiroku-backed -adapter, 'AckRetry' remains bounded by the subscription @RetryPolicy@ (five -total deliveries by default). Exhaustion records the source event in -@kiroku.dead_letters@ with reason kind @max_attempts_exceeded@ and advances the -checkpoint. @KirokuAdapterConfig@ does not currently expose @retryPolicy@; -install 'Keiro.Telemetry.kirokuEventBridge' on Kiroku's @eventHandler@ to observe -the terminal event. The configurable sharded path forwards -@ShardedWorkerOptions.retryPolicy@ through the same Kiroku ladder; see -"Keiro.Subscription.Shard.Worker". --} +-- | Run a 'Router' as a live subscription over a Shibuya 'Adapter'. +-- +-- Mirrors 'Keiro.ProcessManager.runProcessManagerWorker': it drains the adapter's +-- message stream, decoding each message to a @(RecordedEvent, input)@ pair and +-- dispatching it through 'runRouterOnce'. +-- +-- Ack policy (see this plan's Decision Log): +-- +-- * a message that fails to decode follows the configured 'PoisonPolicy' +-- (default: 'AckHalt' @HaltFatal@); +-- * otherwise, after dispatch, if every 'PMCommandResult' is +-- 'PMCommandAppended' or 'PMCommandDuplicate' the message finalizes 'AckOk'; +-- * if any dispatch is 'PMCommandFailed', transient failures finalize +-- 'AckRetry', systemic deterministic failures finalize @AckHalt +-- (HaltFatal …)@, and rejection-class failures follow +-- 'RejectedCommandPolicy'. +-- +-- Benign domain rejections (a target aggregate refusing a "check" command because +-- no edge matches) must be modeled as /total/ transitions in the keiki transducer +-- (an ε-complement self-loop) so they never surface as 'PMCommandFailed' and +-- therefore never wedge the worker. When the rejection is genuinely +-- data-dependent, 'RejectedDeadLetter' persists a queryable +-- "Keiro.DeadLetter.DispatchDeadLetter" and acknowledges the source event; +-- 'RejectedSkip' acknowledges and records only the metric. 'RejectedHalt' remains +-- the default. +-- +-- The worker invokes each ingested message's 'Shibuya.Core.AckHandle.AckHandle' +-- @finalize@ exactly once with the decision, so the decision reaches the adapter. +-- Use 'runRouterWorkerWith' to override poison-message handling, rejected-command +-- handling, transient retry delay, or dispatch metrics. On a Kiroku-backed +-- adapter, 'AckRetry' remains bounded by the subscription @RetryPolicy@ (five +-- total deliveries by default). Exhaustion records the source event in +-- @kiroku.dead_letters@ with reason kind @max_attempts_exceeded@ and advances the +-- checkpoint. @KirokuAdapterConfig@ does not currently expose @retryPolicy@; +-- install 'Keiro.Telemetry.kirokuEventBridge' on Kiroku's @eventHandler@ to observe +-- the terminal event. The configurable sharded path forwards +-- @ShardedWorkerOptions.retryPolicy@ through the same Kiroku ladder; see +-- "Keiro.Subscription.Shard.Worker". runRouterWorker :: - forall msg input targetPhi targetRs targetState targetCi targetCo es. - ( HasCallStack - , IOE :> es - , Store :> es - , Error StoreError :> es - , KirokuStoreResource :> es - , BoolAlg targetPhi (RegFile targetRs, targetCi) - , Eq targetCo - ) => - RunCommandOptions -> - Router input targetPhi targetRs targetState targetCi targetCo es -> - Adapter es msg -> - (msg -> Maybe (RecordedEvent, input)) -> - Eff es () + forall msg input targetPhi targetRs targetState targetCi targetCo es. + ( HasCallStack, + IOE :> es, + Store :> es, + Error StoreError :> es, + KirokuStoreResource :> es, + BoolAlg targetPhi (RegFile targetRs, targetCi), + Eq targetCo + ) => + RunCommandOptions -> + Router input targetPhi targetRs targetState targetCi targetCo es -> + Adapter es msg -> + (msg -> Maybe (RecordedEvent, input)) -> + Eff es () runRouterWorker = - runRouterWorkerWith defaultWorkerOptions + runRouterWorkerWith defaultWorkerOptions runRouterWorkerWith :: - forall msg input targetPhi targetRs targetState targetCi targetCo es. - ( HasCallStack - , IOE :> es - , Store :> es - , Error StoreError :> es - , KirokuStoreResource :> es - , BoolAlg targetPhi (RegFile targetRs, targetCi) - , Eq targetCo - ) => - WorkerOptions es msg -> - RunCommandOptions -> - Router input targetPhi targetRs targetState targetCi targetCo es -> - Adapter es msg -> - (msg -> Maybe (RecordedEvent, input)) -> - Eff es () -runRouterWorkerWith workerOptions options router Adapter{source = adapterSource} decodeMessage = - Streamly.fold Fold.drain - $ Streamly.mapM handleIngested adapterSource + forall msg input targetPhi targetRs targetState targetCi targetCo es. + ( HasCallStack, + IOE :> es, + Store :> es, + Error StoreError :> es, + KirokuStoreResource :> es, + BoolAlg targetPhi (RegFile targetRs, targetCi), + Eq targetCo + ) => + WorkerOptions es msg -> + RunCommandOptions -> + Router input targetPhi targetRs targetState targetCi targetCo es -> + Adapter es msg -> + (msg -> Maybe (RecordedEvent, input)) -> + Eff es () +runRouterWorkerWith workerOptions options router Adapter {source = adapterSource} decodeMessage = + Streamly.fold Fold.drain + $ Streamly.mapM handleIngested adapterSource where handleIngested :: Ingested es msg -> Eff es AckDecision - handleIngested Ingested{envelope = env@Envelope{payload = message}, ack = AckHandle finalizeAck} = do - decision <- case decodeMessage message of - Nothing -> decideForPoison "router worker could not decode message" env - Just (recorded, input) -> do - let correlationId = (router ^. #key) input - attemptCount = envelopeAttemptCount env - outcome <- tryError @StoreError (runRouterOnce options router recorded input) - case outcome of - Left (_, storeErr) -> do - recordDispatchFailed (workerOptions ^. #metrics) 1 - pure (ackForCommandError (workerOptions ^. #transientRetryDelay) (StoreFailed storeErr)) - Right (RouterResult results) -> ackDecisionFor recorded correlationId attemptCount results - finalizeAck decision - pure decision + handleIngested Ingested {envelope = env@Envelope {payload = message}, ack = AckHandle finalizeAck} = do + decision <- case decodeMessage message of + Nothing -> decideForPoison "router worker could not decode message" env + Just (recorded, input) -> do + let correlationId = (router ^. #key) input + attemptCount = envelopeAttemptCount env + outcome <- tryError @StoreError (runRouterOnce options router recorded input) + case outcome of + Left (_, storeErr) -> do + recordDispatchFailed (workerOptions ^. #metrics) 1 + pure (ackForCommandError (workerOptions ^. #transientRetryDelay) (StoreFailed storeErr)) + Right (RouterResult results) -> ackDecisionFor recorded correlationId attemptCount results + finalizeAck decision + pure decision ackDecisionFor :: RecordedEvent -> Text -> Int -> [PMCommandResult target] -> Eff es AckDecision ackDecisionFor sourceEvent correlationId attemptCount results = do - let duplicateCount = commandDuplicateCount results - failures = - [ DispatchFailure emitIndex targetStreamName err - | (emitIndex, PMCommandFailed targetStreamName err) <- zip [0 ..] results - ] - recordDispatchDuplicate (workerOptions ^. #metrics) duplicateCount - recordDispatchFailed (workerOptions ^. #metrics) (fromIntegral (length failures)) - decideForFailures - workerOptions - DispatcherRouter - (router ^. #name) - correlationId - sourceEvent - attemptCount - failures + let duplicateCount = commandDuplicateCount results + failures = + [ DispatchFailure emitIndex targetStreamName err + | (emitIndex, PMCommandFailed targetStreamName err) <- zip [0 ..] results + ] + recordDispatchDuplicate (workerOptions ^. #metrics) duplicateCount + recordDispatchFailed (workerOptions ^. #metrics) (fromIntegral (length failures)) + decideForFailures + workerOptions + DispatcherRouter + (router ^. #name) + correlationId + sourceEvent + attemptCount + failures commandDuplicateCount :: [PMCommandResult target] -> Int64 commandDuplicateCount = - fromIntegral . length . filter isDuplicateResult + fromIntegral . length . filter isDuplicateResult where isDuplicateResult = \case - PMCommandDuplicate{} -> True - _ -> False + PMCommandDuplicate {} -> True + _ -> False decideForPoison :: Text -> Envelope msg -> Eff es AckDecision decideForPoison reason env = do - recordDispatchPoison (workerOptions ^. #metrics) 1 - case workerOptions ^. #poisonPolicy of - PoisonHalt -> pure (AckHalt (HaltFatal reason)) - PoisonSkip callback -> do - callback env - pure AckOk - PoisonDeadLetter callback -> do - callback env - pure (AckDeadLetter (InvalidPayload reason)) + recordDispatchPoison (workerOptions ^. #metrics) 1 + case workerOptions ^. #poisonPolicy of + PoisonHalt -> pure (AckHalt (HaltFatal reason)) + PoisonSkip callback -> do + callback env + pure AckOk + PoisonDeadLetter callback -> do + callback env + pure (AckDeadLetter (InvalidPayload reason)) envelopeAttemptCount :: Envelope msg -> Int envelopeAttemptCount env = - case env ^. #attempt of - Nothing -> 1 - Just (Attempt attempt) -> fromIntegral attempt + 1 + case env ^. #attempt of + Nothing -> 1 + Just (Attempt attempt) -> fromIntegral attempt + 1 diff --git a/src/Keiro/Snapshot.hs b/src/Keiro/Snapshot.hs --- a/src/Keiro/Snapshot.hs +++ b/src/Keiro/Snapshot.hs @@ -1,27 +1,26 @@ -{- | Snapshots: skipping replay by persisting folded aggregate state. - -A snapshot stores an aggregate's @(state, registers)@ at a known stream -version so hydration can start there instead of replaying the whole event -log. 'hydrateWithSnapshot' loads the latest compatible snapshot for a -stream (returning a 'SnapshotSeed' the command runner replays /forward/ -from), and 'writeSnapshot' persists one after an append when the stream's -'Keiro.EventStream.SnapshotPolicy' fires. - -Compatibility is gated by the version, register-file shape hash, and -control-state shape/fold hash of the 'StateCodec': a snapshot is only loaded -when all three match the current codec, so an incompatible encoding, register -layout, or folded-state interpretation transparently falls back to a full -replay. The JSON encoding lives in "Keiro.Snapshot.Codec" and the SQL storage -in "Keiro.Snapshot.Schema", both re-exported here. - -Snapshot version non-regression applies only while all three discriminators -stay the same. A writer with any discriminant changed may replace a -higher-version row, allowing codec rollback to recover. In a mixed-version -deployment incompatible writers can therefore thrash the one row per stream -and repeatedly force full replay; this affects performance, not correctness. --} -module Keiro.Snapshot ( - -- * Hydration seed +-- | Snapshots: skipping replay by persisting folded aggregate state. +-- +-- A snapshot stores an aggregate's @(state, registers)@ at a known stream +-- version so hydration can start there instead of replaying the whole event +-- log. 'hydrateWithSnapshot' loads the latest compatible snapshot for a +-- stream (returning a 'SnapshotSeed' the command runner replays /forward/ +-- from), and 'writeSnapshot' persists one after an append when the stream's +-- 'Keiro.EventStream.SnapshotPolicy' fires. +-- +-- Compatibility is gated by the version, register-file shape hash, and +-- control-state shape/fold hash of the 'StateCodec': a snapshot is only loaded +-- when all three match the current codec, so an incompatible encoding, register +-- layout, or folded-state interpretation transparently falls back to a full +-- replay. The JSON encoding lives in "Keiro.Snapshot.Codec" and the SQL storage +-- in "Keiro.Snapshot.Schema", both re-exported here. +-- +-- Snapshot version non-regression applies only while all three discriminators +-- stay the same. A writer with any discriminant changed may replace a +-- higher-version row, allowing codec rollback to recover. In a mixed-version +-- deployment incompatible writers can therefore thrash the one row per stream +-- and repeatedly force full replay; this affects performance, not correctness. +module Keiro.Snapshot + ( -- * Hydration seed SnapshotSeed (..), SnapshotMissReason (..), SnapshotLookup (..), @@ -34,7 +33,7 @@ -- * State codec and storage module Keiro.Snapshot.Codec, module Keiro.Snapshot.Schema, -) + ) where import Control.DeepSeq (force) @@ -49,126 +48,120 @@ import Kiroku.Store.Read (lookupStreamId) import Kiroku.Store.Types (StreamId, StreamName, StreamVersion) -{- | A decoded snapshot the command runner replays forward from: the folded -'state' and 'registers' as of 'streamVersion'. Hydration reads only the -events after 'streamVersion' instead of the entire stream. --} +-- | A decoded snapshot the command runner replays forward from: the folded +-- 'state' and 'registers' as of 'streamVersion'. Hydration reads only the +-- events after 'streamVersion' instead of the entire stream. data SnapshotSeed rs s = SnapshotSeed - { state :: !s - , registers :: !(RegFile rs) - , streamVersion :: !StreamVersion - } - deriving stock (Generic) + { state :: !s, + registers :: !(RegFile rs), + streamVersion :: !StreamVersion + } + deriving stock (Generic) -- | Why a snapshot lookup produced no usable hydration seed. data SnapshotMissReason - = SnapshotNoStream - | SnapshotNotFound - | SnapshotDecodeFailed !Text - deriving stock (Eq, Show, Generic) + = SnapshotNoStream + | SnapshotNotFound + | SnapshotDecodeFailed !Text + deriving stock (Eq, Show, Generic) -- | The observable result of looking up and decoding an aggregate snapshot. data SnapshotLookup rs s - = SnapshotUnavailable !SnapshotMissReason - | SnapshotHit !(SnapshotSeed rs s) - deriving stock (Generic) + = SnapshotUnavailable !SnapshotMissReason + | SnapshotHit !(SnapshotSeed rs s) + deriving stock (Generic) -{- | Look up the latest compatible snapshot and retain the reason when no -usable seed exists. A matching row that fails to decode is distinguished from -a missing stream or row so callers can report the persistent fallback. --} +-- | Look up the latest compatible snapshot and retain the reason when no +-- usable seed exists. A matching row that fails to decode is distinguished from +-- a missing stream or row so callers can report the persistent fallback. lookupSnapshotSeed :: - (Store :> es) => - StreamName -> - StateCodec (s, RegFile rs) -> - Eff es (SnapshotLookup rs s) + (Store :> es) => + StreamName -> + StateCodec (s, RegFile rs) -> + Eff es (SnapshotLookup rs s) lookupSnapshotSeed streamName codec = do - streamId <- lookupStreamId streamName - case streamId of - Nothing -> pure (SnapshotUnavailable SnapshotNoStream) - Just foundStreamId -> do - row <- - lookupSnapshot - foundStreamId - (codec ^. #stateCodecVersion) - (codec ^. #shapeHash) - (codec ^. #stateShapeHash) - pure $ case row of - Nothing -> SnapshotUnavailable SnapshotNotFound - Just snapshot -> - case (codec ^. #decode) (snapshot ^. #state) of - Left message -> SnapshotUnavailable (SnapshotDecodeFailed message) - Right (state, registers) -> - SnapshotHit - SnapshotSeed - { state = state - , registers = registers - , streamVersion = snapshot ^. #streamVersion - } - -{- | Load the latest snapshot compatible with @codec@ for the named stream. + streamId <- lookupStreamId streamName + case streamId of + Nothing -> pure (SnapshotUnavailable SnapshotNoStream) + Just foundStreamId -> do + row <- + lookupSnapshot + foundStreamId + (codec ^. #stateCodecVersion) + (codec ^. #shapeHash) + (codec ^. #stateShapeHash) + pure $ case row of + Nothing -> SnapshotUnavailable SnapshotNotFound + Just snapshot -> + case (codec ^. #decode) (snapshot ^. #state) of + Left message -> SnapshotUnavailable (SnapshotDecodeFailed message) + Right (state, registers) -> + SnapshotHit + SnapshotSeed + { state = state, + registers = registers, + streamVersion = snapshot ^. #streamVersion + } -Returns 'Nothing' — meaning "replay from the beginning" — when the stream -has no id yet, has no snapshot matching all three codec discriminators, or has -a snapshot whose bytes fail to decode. Decode failure is treated as a benign -miss rather than an error, so a corrupt or stale snapshot never blocks -hydration. --} +-- | Load the latest snapshot compatible with @codec@ for the named stream. +-- +-- Returns 'Nothing' — meaning "replay from the beginning" — when the stream +-- has no id yet, has no snapshot matching all three codec discriminators, or has +-- a snapshot whose bytes fail to decode. Decode failure is treated as a benign +-- miss rather than an error, so a corrupt or stale snapshot never blocks +-- hydration. hydrateWithSnapshot :: - (Store :> es) => - StreamName -> - StateCodec (s, RegFile rs) -> - Eff es (Maybe (SnapshotSeed rs s)) + (Store :> es) => + StreamName -> + StateCodec (s, RegFile rs) -> + Eff es (Maybe (SnapshotSeed rs s)) hydrateWithSnapshot streamName codec = do - lookupSnapshotSeed streamName codec <&> \case - SnapshotUnavailable _ -> Nothing - SnapshotHit seed -> Just seed + lookupSnapshotSeed streamName codec <&> \case + SnapshotUnavailable _ -> Nothing + SnapshotHit seed -> Just seed -{- | Strictly encode @state@ with @codec@, forcing the complete JSON value and -returning an 'ErrorCall' raised by a partial encoder or an uninitialized keiki -register. Other exception types deliberately remain visible to the caller. --} +-- | Strictly encode @state@ with @codec@, forcing the complete JSON value and +-- returning an 'ErrorCall' raised by a partial encoder or an uninitialized keiki +-- register. Other exception types deliberately remain visible to the caller. encodeSnapshotStrict :: StateCodec state -> state -> IO (Either ErrorCall Value) encodeSnapshotStrict codec state = - try @ErrorCall (evaluate (force ((codec ^. #encode) state))) + try @ErrorCall (evaluate (force ((codec ^. #encode) state))) -{- | Upsert a JSON value that has already been encoded and forced. Keeping this -separate from 'writeSnapshot' lets post-commit callers prove encoding is safe -before they touch the store. For fixed codec discriminators, stale versions -are ignored. Any changed discriminator may replace a higher-version row to -permit codec rollback; see the module header. --} +-- | Upsert a JSON value that has already been encoded and forced. Keeping this +-- separate from 'writeSnapshot' lets post-commit callers prove encoding is safe +-- before they touch the store. For fixed codec discriminators, stale versions +-- are ignored. Any changed discriminator may replace a higher-version row to +-- permit codec rollback; see the module header. writeSnapshotEncoded :: - (Store :> es) => - StreamId -> - StreamVersion -> - StateCodec state -> - Value -> - Eff es () + (Store :> es) => + StreamId -> + StreamVersion -> + StateCodec state -> + Value -> + Eff es () writeSnapshotEncoded streamId streamVersion codec encoded = - writeSnapshotRow - SnapshotWrite - { streamId = streamId - , streamVersion = streamVersion - , state = encoded - , stateCodecVersion = codec ^. #stateCodecVersion - , regfileShapeHash = codec ^. #shapeHash - , stateShapeHash = codec ^. #stateShapeHash - } + writeSnapshotRow + SnapshotWrite + { streamId = streamId, + streamVersion = streamVersion, + state = encoded, + stateCodecVersion = codec ^. #stateCodecVersion, + regfileShapeHash = codec ^. #shapeHash, + stateShapeHash = codec ^. #stateShapeHash + } -{- | Encode @state@ with @codec@ and upsert it as the snapshot for the given -stream at @streamVersion@. This compatibility helper preserves the historical -lazy encoding behavior; post-commit advisory paths should call -'encodeSnapshotStrict' first and pass the result to 'writeSnapshotEncoded'. For -fixed codec discriminators stale writes are ignored, while an incompatible -codec may replace a newer row to permit rollback. --} +-- | Encode @state@ with @codec@ and upsert it as the snapshot for the given +-- stream at @streamVersion@. This compatibility helper preserves the historical +-- lazy encoding behavior; post-commit advisory paths should call +-- 'encodeSnapshotStrict' first and pass the result to 'writeSnapshotEncoded'. For +-- fixed codec discriminators stale writes are ignored, while an incompatible +-- codec may replace a newer row to permit rollback. writeSnapshot :: - (Store :> es) => - StreamId -> - StreamVersion -> - StateCodec state -> - state -> - Eff es () + (Store :> es) => + StreamId -> + StreamVersion -> + StateCodec state -> + state -> + Eff es () writeSnapshot streamId streamVersion codec state = - writeSnapshotEncoded streamId streamVersion codec ((codec ^. #encode) state) + writeSnapshotEncoded streamId streamVersion codec ((codec ^. #encode) state) diff --git a/src/Keiro/Snapshot/Codec.hs b/src/Keiro/Snapshot/Codec.hs --- a/src/Keiro/Snapshot/Codec.hs +++ b/src/Keiro/Snapshot/Codec.hs @@ -1,30 +1,29 @@ -{- | The default JSON encoding for aggregate snapshots. - -'defaultStateCodecWithFold' builds the recommended 'StateCodec' for a -hand-written service's @(state, registers)@ pair, serializing it as a JSON -object @{ "state": …, "registers": … }@ and composing a hand-owned -'FoldVersion' into the snapshot discriminator. Change the fold version in the -same edit that changes the service's event-folding behavior. - -'defaultStateCodec' builds the underlying codec for the @(state, registers)@ pair -of a keiki machine, serializing it as a JSON object @{ "state": …, -"registers": … }@. The state half uses its 'ToJSON' \/ 'FromJSON' -instances; the register half uses keiki's register-file JSON encoding. The -codec derives separate hashes for the control-state shape and register-file -layout, so structural changes transparently invalidate older snapshots (see -"Keiro.Snapshot"). - -Generated services use 'withFoldFingerprint' directly with a fingerprint -derived from their spec. Hand-written guard and update function bodies are not -structurally inspectable, so hand-written services should use -'defaultStateCodecWithFold' and maintain its explicit 'FoldVersion'. --} -module Keiro.Snapshot.Codec ( - FoldVersion (..), +-- | The default JSON encoding for aggregate snapshots. +-- +-- 'defaultStateCodecWithFold' builds the recommended 'StateCodec' for a +-- hand-written service's @(state, registers)@ pair, serializing it as a JSON +-- object @{ "state": …, "registers": … }@ and composing a hand-owned +-- 'FoldVersion' into the snapshot discriminator. Change the fold version in the +-- same edit that changes the service's event-folding behavior. +-- +-- 'defaultStateCodec' builds the underlying codec for the @(state, registers)@ pair +-- of a keiki machine, serializing it as a JSON object @{ "state": …, +-- "registers": … }@. The state half uses its 'ToJSON' \/ 'FromJSON' +-- instances; the register half uses keiki's register-file JSON encoding. The +-- codec derives separate hashes for the control-state shape and register-file +-- layout, so structural changes transparently invalidate older snapshots (see +-- "Keiro.Snapshot"). +-- +-- Generated services use 'withFoldFingerprint' directly with a fingerprint +-- derived from their spec. Hand-written guard and update function bodies are not +-- structurally inspectable, so hand-written services should use +-- 'defaultStateCodecWithFold' and maintain its explicit 'FoldVersion'. +module Keiro.Snapshot.Codec + ( FoldVersion (..), defaultStateCodec, defaultStateCodecWithFold, withFoldFingerprint, -) + ) where import Data.Aeson (Result (..), object, withObject, (.:)) @@ -38,99 +37,95 @@ import Keiro.EventStream (StateCodec (..)) import Keiro.Prelude -{- | A 'StateCodec' that serializes a @(state, registers)@ pair to a JSON -object, tagging it with the supplied codec version and hashes derived from the -control-state datatype and register-file layout. - -This function does not identify changes to hand-written guards, register -updates, emitted outputs, targets, or helper functions used by the fold. Prefer -'defaultStateCodecWithFold' for hand-written services. Generated services use -'withFoldFingerprint' with a fingerprint derived from their spec. --} +-- | A 'StateCodec' that serializes a @(state, registers)@ pair to a JSON +-- object, tagging it with the supplied codec version and hashes derived from the +-- control-state datatype and register-file layout. +-- +-- This function does not identify changes to hand-written guards, register +-- updates, emitted outputs, targets, or helper functions used by the fold. Prefer +-- 'defaultStateCodecWithFold' for hand-written services. Generated services use +-- 'withFoldFingerprint' with a fingerprint derived from their spec. defaultStateCodec :: - forall rs s. - (CanonicalStateShape s, FromJSON s, KnownRegFileShape rs, RegFileToJSON rs, ToJSON s) => - Int -> - StateCodec (s, RegFile rs) + forall rs s. + (CanonicalStateShape s, FromJSON s, KnownRegFileShape rs, RegFileToJSON rs, ToJSON s) => + Int -> + StateCodec (s, RegFile rs) defaultStateCodec version = - StateCodec - { stateCodecVersion = version - , shapeHash = regFileShapeHash (Proxy @rs) - , stateShapeHash = Shape.stateShapeHash (Proxy @s) - , encode = \(state, registers) -> - object - [ "state" Aeson..= state - , "registers" Aeson..= regFileToJSON registers - ] - , decode = decodeSnapshotValue - } - -{- | A hand-owned identity for a hand-written service's event fold. + StateCodec + { stateCodecVersion = version, + shapeHash = regFileShapeHash (Proxy @rs), + stateShapeHash = Shape.stateShapeHash (Proxy @s), + encode = \(state, registers) -> + object + [ "state" Aeson..= state, + "registers" Aeson..= regFileToJSON registers + ], + decode = decodeSnapshotValue + } -The DSL derives a fold fingerprint from the spec automatically; a hand-written -service has no spec, so its fold identity must be owned by hand. Treat the -token as a change detector, not an encoding version: keep it stable while fold -semantics are stable, and change it in the same edit that changes any guard, -register update, emitted output, or target state, including logic in helper -functions the fold calls. A convention such as @"orders-fold-v3"@ keeps the -token greppable and reviewable. Forgetting to bump it recreates the silent -stale-snapshot hazard this type exists to prevent; see -'defaultStateCodecWithFold'. --} +-- | A hand-owned identity for a hand-written service's event fold. +-- +-- The DSL derives a fold fingerprint from the spec automatically; a hand-written +-- service has no spec, so its fold identity must be owned by hand. Treat the +-- token as a change detector, not an encoding version: keep it stable while fold +-- semantics are stable, and change it in the same edit that changes any guard, +-- register update, emitted output, or target state, including logic in helper +-- functions the fold calls. A convention such as @"orders-fold-v3"@ keeps the +-- token greppable and reviewable. Forgetting to bump it recreates the silent +-- stale-snapshot hazard this type exists to prevent; see +-- 'defaultStateCodecWithFold'. newtype FoldVersion = FoldVersion Text - deriving stock (Eq, Show) - -{- | The default snapshot codec for hand-written services: 'defaultStateCodec' -with a hand-owned 'FoldVersion' composed into the control-state discriminator -via 'withFoldFingerprint'. + deriving stock (Eq, Show) -Prefer this over bare 'defaultStateCodec' whenever the service's fold is -hand-written. A changed token changes the stored discriminator, so an old -snapshot is simply not found and hydration falls back to a full replay of the -event log: a performance cost, never wrong state. The rendered discriminator -stays operator-readable as @;fold=@. --} +-- | The default snapshot codec for hand-written services: 'defaultStateCodec' +-- with a hand-owned 'FoldVersion' composed into the control-state discriminator +-- via 'withFoldFingerprint'. +-- +-- Prefer this over bare 'defaultStateCodec' whenever the service's fold is +-- hand-written. A changed token changes the stored discriminator, so an old +-- snapshot is simply not found and hydration falls back to a full replay of the +-- event log: a performance cost, never wrong state. The rendered discriminator +-- stays operator-readable as @;fold=@. defaultStateCodecWithFold :: - forall rs s. - (CanonicalStateShape s, FromJSON s, KnownRegFileShape rs, RegFileToJSON rs, ToJSON s) => - FoldVersion -> - Int -> - StateCodec (s, RegFile rs) + forall rs s. + (CanonicalStateShape s, FromJSON s, KnownRegFileShape rs, RegFileToJSON rs, ToJSON s) => + FoldVersion -> + Int -> + StateCodec (s, RegFile rs) defaultStateCodecWithFold (FoldVersion token) version = - withFoldFingerprint token (defaultStateCodec version) - -{- | Compose a caller-supplied fold identity into the control-state -discriminator. + withFoldFingerprint token (defaultStateCodec version) -The fingerprint is a change detector, not an encoding version. Keep it stable -when fold semantics are stable and change it whenever guards, updates, targets, -or other event-folding behavior changes. The rendered form remains -operator-readable as @;fold=@. --} +-- | Compose a caller-supplied fold identity into the control-state +-- discriminator. +-- +-- The fingerprint is a change detector, not an encoding version. Keep it stable +-- when fold semantics are stable and change it whenever guards, updates, targets, +-- or other event-folding behavior changes. The rendered form remains +-- operator-readable as @;fold=@. withFoldFingerprint :: Text -> StateCodec state -> StateCodec state withFoldFingerprint fingerprint codec = - codec - { stateShapeHash = - codec ^. #stateShapeHash <> ";fold=" <> fingerprint - } + codec + { stateShapeHash = + codec ^. #stateShapeHash <> ";fold=" <> fingerprint + } decodeSnapshotValue :: - forall rs s. - (FromJSON s, RegFileToJSON rs) => - Value -> - Either Text (s, RegFile rs) + forall rs s. + (FromJSON s, RegFileToJSON rs) => + Value -> + Either Text (s, RegFile rs) decodeSnapshotValue value = - case parseEither parser value of - Left message -> Left (Text.pack message) - Right pair -> Right pair + case parseEither parser value of + Left message -> Left (Text.pack message) + Right pair -> Right pair where parser = withObject "Keiro snapshot" $ \objectValue -> do - stateValue <- objectValue .: "state" - registerValue <- objectValue .: "registers" - state <- case Aeson.fromJSON stateValue of - Error message -> fail ("state: " <> message) - Success decoded -> pure decoded - registers <- case regFileFromJSON @rs registerValue of - Left message -> fail ("registers: " <> message) - Right decoded -> pure decoded - pure (state, registers) + stateValue <- objectValue .: "state" + registerValue <- objectValue .: "registers" + state <- case Aeson.fromJSON stateValue of + Error message -> fail ("state: " <> message) + Success decoded -> pure decoded + registers <- case regFileFromJSON @rs registerValue of + Left message -> fail ("registers: " <> message) + Right decoded -> pure decoded + pure (state, registers) diff --git a/src/Keiro/Snapshot/Schema.hs b/src/Keiro/Snapshot/Schema.hs --- a/src/Keiro/Snapshot/Schema.hs +++ b/src/Keiro/Snapshot/Schema.hs @@ -1,33 +1,32 @@ -{- | The @keiro_snapshots@ table: persistence for aggregate snapshots. - -One row per stream holds the latest snapshot of its folded state as JSONB, -tagged with the 'stateCodecVersion', 'regfileShapeHash', and 'stateShapeHash' -that produced it. 'lookupSnapshot' fetches the newest row matching all three -discriminators (so incompatible snapshots are simply not found). Within one -discriminator tuple, 'writeSnapshotRow' keeps only the highest stream version, -so a late or out-of-order write cannot regress the snapshot. - -A write with a /different/ discriminator deliberately replaces the row even -at a lower stream version. This lets a rolled-back deployment -reclaim the single snapshot slot instead of being locked out by a newer codec -forever. During a mixed-version deployment, however, writers with incompatible -codecs can thrash that row and each side will miss the other's snapshot. The -cost is repeated full replay, never incorrect state: the event log remains the -source of truth. - -This module is the storage layer beneath "Keiro.Snapshot"; callers normally -go through 'Keiro.Snapshot.hydrateWithSnapshot' and -'Keiro.Snapshot.writeSnapshot' rather than these statements directly. --} -module Keiro.Snapshot.Schema ( - -- * Rows +-- | The @keiro_snapshots@ table: persistence for aggregate snapshots. +-- +-- One row per stream holds the latest snapshot of its folded state as JSONB, +-- tagged with the 'stateCodecVersion', 'regfileShapeHash', and 'stateShapeHash' +-- that produced it. 'lookupSnapshot' fetches the newest row matching all three +-- discriminators (so incompatible snapshots are simply not found). Within one +-- discriminator tuple, 'writeSnapshotRow' keeps only the highest stream version, +-- so a late or out-of-order write cannot regress the snapshot. +-- +-- A write with a /different/ discriminator deliberately replaces the row even +-- at a lower stream version. This lets a rolled-back deployment +-- reclaim the single snapshot slot instead of being locked out by a newer codec +-- forever. During a mixed-version deployment, however, writers with incompatible +-- codecs can thrash that row and each side will miss the other's snapshot. The +-- cost is repeated full replay, never incorrect state: the event log remains the +-- source of truth. +-- +-- This module is the storage layer beneath "Keiro.Snapshot"; callers normally +-- go through 'Keiro.Snapshot.hydrateWithSnapshot' and +-- 'Keiro.Snapshot.writeSnapshot' rather than these statements directly. +module Keiro.Snapshot.Schema + ( -- * Rows SnapshotRow (..), SnapshotWrite (..), -- * Storage lookupSnapshot, writeSnapshotRow, -) + ) where import Contravariant.Extras (contrazip4, contrazip6) @@ -42,129 +41,125 @@ import "hasql-transaction" Hasql.Transaction qualified as Tx import Prelude qualified -{- | A snapshot row as read back from @keiro_snapshots@: the stored 'state' -JSON, the 'streamVersion' it captures, the 'stateCodecVersion' and -'regfileShapeHash' and 'stateShapeHash' that gate compatibility, and the create/update -timestamps. --} +-- | A snapshot row as read back from @keiro_snapshots@: the stored 'state' +-- JSON, the 'streamVersion' it captures, the 'stateCodecVersion' and +-- 'regfileShapeHash' and 'stateShapeHash' that gate compatibility, and the create/update +-- timestamps. data SnapshotRow = SnapshotRow - { streamId :: !StreamId - , streamVersion :: !StreamVersion - , state :: !Value - , stateCodecVersion :: !Int - , regfileShapeHash :: !Text - , stateShapeHash :: !Text - , createdAt :: !UTCTime - , updatedAt :: !UTCTime - } - deriving stock (Generic, Eq, Show) + { streamId :: !StreamId, + streamVersion :: !StreamVersion, + state :: !Value, + stateCodecVersion :: !Int, + regfileShapeHash :: !Text, + stateShapeHash :: !Text, + createdAt :: !UTCTime, + updatedAt :: !UTCTime + } + deriving stock (Generic, Eq, Show) -{- | The fields needed to write a snapshot — 'SnapshotRow' minus the -database-managed timestamps. --} +-- | The fields needed to write a snapshot — 'SnapshotRow' minus the +-- database-managed timestamps. data SnapshotWrite = SnapshotWrite - { streamId :: !StreamId - , streamVersion :: !StreamVersion - , state :: !Value - , stateCodecVersion :: !Int - , regfileShapeHash :: !Text - , stateShapeHash :: !Text - } - deriving stock (Generic, Eq, Show) + { streamId :: !StreamId, + streamVersion :: !StreamVersion, + state :: !Value, + stateCodecVersion :: !Int, + regfileShapeHash :: !Text, + stateShapeHash :: !Text + } + deriving stock (Generic, Eq, Show) -{- | Fetch the latest snapshot for a stream that matches all three codec -discriminators. Returns 'Nothing' when no compatible snapshot exists, so an -incompatible one is treated as absent. --} +-- | Fetch the latest snapshot for a stream that matches all three codec +-- discriminators. Returns 'Nothing' when no compatible snapshot exists, so an +-- incompatible one is treated as absent. lookupSnapshot :: - (Store :> es) => - StreamId -> - Int -> - Text -> - Text -> - Eff es (Maybe SnapshotRow) + (Store :> es) => + StreamId -> + Int -> + Text -> + Text -> + Eff es (Maybe SnapshotRow) lookupSnapshot streamId version shapeHash stateShapeHash = - runTransaction - $ Tx.statement - (streamIdToInt streamId, Prelude.fromIntegral version, shapeHash, stateShapeHash) - lookupSnapshotStmt + runTransaction + $ Tx.statement + (streamIdToInt streamId, Prelude.fromIntegral version, shapeHash, stateShapeHash) + lookupSnapshotStmt -{- | Upsert a snapshot row for its stream. For the same discriminator tuple, -the write only takes effect when its 'streamVersion' is at least the stored -one. Any incompatible discriminator replaces the row even at a lower version -so codec rollback can make progress; see the module header for the -mixed-deployment performance caveat. --} +-- | Upsert a snapshot row for its stream. For the same discriminator tuple, +-- the write only takes effect when its 'streamVersion' is at least the stored +-- one. Any incompatible discriminator replaces the row even at a lower version +-- so codec rollback can make progress; see the module header for the +-- mixed-deployment performance caveat. writeSnapshotRow :: - (Store :> es) => - SnapshotWrite -> - Eff es () + (Store :> es) => + SnapshotWrite -> + Eff es () writeSnapshotRow snapshot = - runTransaction - $ Tx.statement (snapshotWriteParams snapshot) writeSnapshotStmt + runTransaction + $ Tx.statement (snapshotWriteParams snapshot) writeSnapshotStmt lookupSnapshotStmt :: Statement (Int64, Int64, Text, Text) (Maybe SnapshotRow) lookupSnapshotStmt = - preparable - """ - SELECT stream_id, stream_version, state, state_codec_version, regfile_shape_hash, state_shape_hash, created_at, updated_at - FROM keiro.keiro_snapshots - WHERE stream_id = $1 - AND state_codec_version = $2 - AND regfile_shape_hash = $3 - AND state_shape_hash = $4 - ORDER BY stream_version DESC - LIMIT 1 - """ - ( contrazip4 - (E.param (E.nonNullable E.int8)) - (E.param (E.nonNullable E.int8)) - (E.param (E.nonNullable E.text)) - (E.param (E.nonNullable E.text)) - ) - (D.rowMaybe snapshotRowDecoder) + preparable + """ + SELECT stream_id, stream_version, state, state_codec_version, regfile_shape_hash, state_shape_hash, created_at, updated_at + FROM keiro.keiro_snapshots + WHERE stream_id = $1 + AND state_codec_version = $2 + AND regfile_shape_hash = $3 + AND state_shape_hash = $4 + ORDER BY stream_version DESC + LIMIT 1 + """ + ( contrazip4 + (E.param (E.nonNullable E.int8)) + (E.param (E.nonNullable E.int8)) + (E.param (E.nonNullable E.text)) + (E.param (E.nonNullable E.text)) + ) + (D.rowMaybe snapshotRowDecoder) writeSnapshotStmt :: Statement (Int64, Int64, Value, Int64, Text, Text) () writeSnapshotStmt = - preparable - """ - INSERT INTO keiro.keiro_snapshots - (stream_id, stream_version, state, state_codec_version, regfile_shape_hash, state_shape_hash) - VALUES - ($1, $2, $3, $4, $5, $6) - ON CONFLICT (stream_id) DO UPDATE - SET stream_version = EXCLUDED.stream_version, - state = EXCLUDED.state, - state_codec_version = EXCLUDED.state_codec_version, - regfile_shape_hash = EXCLUDED.regfile_shape_hash, - state_shape_hash = EXCLUDED.state_shape_hash, - updated_at = now() - WHERE keiro_snapshots.stream_version <= EXCLUDED.stream_version - OR keiro_snapshots.state_codec_version <> EXCLUDED.state_codec_version - OR keiro_snapshots.regfile_shape_hash <> EXCLUDED.regfile_shape_hash - OR keiro_snapshots.state_shape_hash <> EXCLUDED.state_shape_hash - """ - ( contrazip6 - (E.param (E.nonNullable E.int8)) - (E.param (E.nonNullable E.int8)) - (E.param (E.nonNullable E.jsonb)) - (E.param (E.nonNullable E.int8)) - (E.param (E.nonNullable E.text)) - (E.param (E.nonNullable E.text)) - ) - D.noResult + preparable + """ + INSERT INTO keiro.keiro_snapshots + (stream_id, stream_version, state, state_codec_version, regfile_shape_hash, state_shape_hash) + VALUES + ($1, $2, $3, $4, $5, $6) + ON CONFLICT (stream_id) DO UPDATE + SET stream_version = EXCLUDED.stream_version, + state = EXCLUDED.state, + state_codec_version = EXCLUDED.state_codec_version, + regfile_shape_hash = EXCLUDED.regfile_shape_hash, + state_shape_hash = EXCLUDED.state_shape_hash, + updated_at = now() + WHERE keiro_snapshots.stream_version <= EXCLUDED.stream_version + OR keiro_snapshots.state_codec_version <> EXCLUDED.state_codec_version + OR keiro_snapshots.regfile_shape_hash <> EXCLUDED.regfile_shape_hash + OR keiro_snapshots.state_shape_hash <> EXCLUDED.state_shape_hash + """ + ( contrazip6 + (E.param (E.nonNullable E.int8)) + (E.param (E.nonNullable E.int8)) + (E.param (E.nonNullable E.jsonb)) + (E.param (E.nonNullable E.int8)) + (E.param (E.nonNullable E.text)) + (E.param (E.nonNullable E.text)) + ) + D.noResult snapshotRowDecoder :: D.Row SnapshotRow snapshotRowDecoder = - SnapshotRow - <$> (StreamId <$> D.column (D.nonNullable D.int8)) - <*> (StreamVersion <$> D.column (D.nonNullable D.int8)) - <*> D.column (D.nonNullable D.jsonb) - <*> (Prelude.fromIntegral <$> D.column (D.nonNullable D.int8)) - <*> D.column (D.nonNullable D.text) - <*> D.column (D.nonNullable D.text) - <*> D.column (D.nonNullable D.timestamptz) - <*> D.column (D.nonNullable D.timestamptz) + SnapshotRow + <$> (StreamId <$> D.column (D.nonNullable D.int8)) + <*> (StreamVersion <$> D.column (D.nonNullable D.int8)) + <*> D.column (D.nonNullable D.jsonb) + <*> (Prelude.fromIntegral <$> D.column (D.nonNullable D.int8)) + <*> D.column (D.nonNullable D.text) + <*> D.column (D.nonNullable D.text) + <*> D.column (D.nonNullable D.timestamptz) + <*> D.column (D.nonNullable D.timestamptz) streamIdToInt :: StreamId -> Int64 streamIdToInt (StreamId value) = value @@ -174,10 +169,10 @@ snapshotWriteParams :: SnapshotWrite -> (Int64, Int64, Value, Int64, Text, Text) snapshotWriteParams snapshot = - ( streamIdToInt (snapshot ^. #streamId) - , streamVersionToInt (snapshot ^. #streamVersion) - , snapshot ^. #state - , Prelude.fromIntegral (snapshot ^. #stateCodecVersion) - , snapshot ^. #regfileShapeHash - , snapshot ^. #stateShapeHash - ) + ( streamIdToInt (snapshot ^. #streamId), + streamVersionToInt (snapshot ^. #streamVersion), + snapshot ^. #state, + Prelude.fromIntegral (snapshot ^. #stateCodecVersion), + snapshot ^. #regfileShapeHash, + snapshot ^. #stateShapeHash + ) diff --git a/src/Keiro/Subscription/Shard.hs b/src/Keiro/Subscription/Shard.hs --- a/src/Keiro/Subscription/Shard.hs +++ b/src/Keiro/Subscription/Shard.hs @@ -1,36 +1,35 @@ -{- | Cooperative consumer-group ownership for category subscriptions (EP-51). - -kiroku already partitions a category into @N@ buckets (consumer-group members) by -a stable hash of the originating stream id, and keeps a per-member checkpoint, so -@N@ disjoint readers can drain a busy category in parallel. What kiroku leaves to -the operator is /membership/: "exactly one live process must own each member -index at a time" is, by itself, a manual @[0..N-1]@ wiring. This module supplies -the missing operability layer — a __lease__ over each bucket so a pool of -identical worker processes agree, with no external coordinator, on who owns which -bucket right now and re-divide the buckets automatically when a worker joins, -leaves, or dies. - -The storage and SQL live in "Keiro.Subscription.Shard.Schema"; this module is the -typed 'Eff'-level surface over kiroku's 'Store': - -* 'freshWorkerId' mints the per-process owner id. -* 'acquireOwnedBuckets' is the one-pass reconcile: renew the leases this worker - still holds, then claim up to a /fair share/ more (taking over any expired - leases), returning the buckets owned after the pass. -* 'renewOwnedBuckets' / 'relinquish' are the heartbeat and the graceful release. -* 'ensureShards' / 'ownershipSnapshot' populate and read the table. - -The lease, not a held lock, is the ownership mechanism: a transaction-scoped -advisory lock auto-releases at transaction end (so it cannot span a worker's -multi-transaction lifetime) and a session-scoped lock has no connection affinity -through kiroku's pooled 'Store' — the same finding -'Keiro.Workflow.Resume.WorkflowResumeOptions' records for the resume worker. A -renewable @lease_expires_at@ timestamp gives lifetime ownership and automatic -failover without depending on connection affinity, and disjointness rests on the -@FOR UPDATE SKIP LOCKED@ claim, not on the liveness estimate being exact. --} -module Keiro.Subscription.Shard ( - -- * Worker identity +-- | Cooperative consumer-group ownership for category subscriptions (EP-51). +-- +-- kiroku already partitions a category into @N@ buckets (consumer-group members) by +-- a stable hash of the originating stream id, and keeps a per-member checkpoint, so +-- @N@ disjoint readers can drain a busy category in parallel. What kiroku leaves to +-- the operator is /membership/: "exactly one live process must own each member +-- index at a time" is, by itself, a manual @[0..N-1]@ wiring. This module supplies +-- the missing operability layer — a __lease__ over each bucket so a pool of +-- identical worker processes agree, with no external coordinator, on who owns which +-- bucket right now and re-divide the buckets automatically when a worker joins, +-- leaves, or dies. +-- +-- The storage and SQL live in "Keiro.Subscription.Shard.Schema"; this module is the +-- typed 'Eff'-level surface over kiroku's 'Store': +-- +-- * 'freshWorkerId' mints the per-process owner id. +-- * 'acquireOwnedBuckets' is the one-pass reconcile: renew the leases this worker +-- still holds, then claim up to a /fair share/ more (taking over any expired +-- leases), returning the buckets owned after the pass. +-- * 'renewOwnedBuckets' / 'relinquish' are the heartbeat and the graceful release. +-- * 'ensureShards' / 'ownershipSnapshot' populate and read the table. +-- +-- The lease, not a held lock, is the ownership mechanism: a transaction-scoped +-- advisory lock auto-releases at transaction end (so it cannot span a worker's +-- multi-transaction lifetime) and a session-scoped lock has no connection affinity +-- through kiroku's pooled 'Store' — the same finding +-- 'Keiro.Workflow.Resume.WorkflowResumeOptions' records for the resume worker. A +-- renewable @lease_expires_at@ timestamp gives lifetime ownership and automatic +-- failover without depending on connection affinity, and disjointness rests on the +-- @FOR UPDATE SKIP LOCKED@ claim, not on the liveness estimate being exact. +module Keiro.Subscription.Shard + ( -- * Worker identity WorkerId (..), freshWorkerId, @@ -47,7 +46,7 @@ -- * Fair-share helper fairShareTarget, -) + ) where import Data.Set (Set) @@ -57,15 +56,15 @@ import Effectful (Eff, IOE, (:>)) import Effectful.Exception (Exception, throwIO) import Keiro.Prelude -import Keiro.Subscription.Shard.Schema ( - WorkerId (..), +import Keiro.Subscription.Shard.Schema + ( WorkerId (..), claimShardsTx, ensureShardRows, listShardCounts, listShardOwnership, releaseShardsTx, renewLeaseTx, - ) + ) import Kiroku.Store.Effect (Store) import Kiroku.Store.Subscription.Types (SubscriptionName (..)) import Kiroku.Store.Transaction (runTransaction) @@ -74,111 +73,104 @@ freshWorkerId :: (IOE :> es) => Eff es WorkerId freshWorkerId = WorkerId <$> liftIO UUIDv4.nextRandom -{- | Everything an ownership pass needs for one @(subscription, worker)@: which -subscription is being sharded, this worker's id, the fixed bucket count @N@, and -how long a claim/renew is valid before it expires. --} +-- | Everything an ownership pass needs for one @(subscription, worker)@: which +-- subscription is being sharded, this worker's id, the fixed bucket count @N@, and +-- how long a claim/renew is valid before it expires. data ShardLease = ShardLease - { subscriptionName :: !SubscriptionName - , workerId :: !WorkerId - , shardCount :: !Int - -- ^ @N@; the fixed number of buckets for this subscription name. - , leaseTtl :: !NominalDiffTime - -- ^ How long a claim or renewal keeps a bucket before it expires. - } - deriving stock (Generic) + { subscriptionName :: !SubscriptionName, + workerId :: !WorkerId, + -- | @N@; the fixed number of buckets for this subscription name. + shardCount :: !Int, + -- | How long a claim or renewal keeps a bucket before it expires. + leaseTtl :: !NominalDiffTime + } + deriving stock (Generic) data ShardCountMismatch = ShardCountMismatch - { mismatchSubscriptionName :: !Text - , mismatchConfigured :: !Int - , mismatchFound :: ![Int] - } - deriving stock (Generic, Eq, Show) - deriving anyclass (Exception) + { mismatchSubscriptionName :: !Text, + mismatchConfigured :: !Int, + mismatchFound :: ![Int] + } + deriving stock (Generic, Eq, Show) + deriving anyclass (Exception) -{- | The fair-share claim target: @ceil(N / liveWorkers)@. When @k@ workers are -live they collectively claim all @N@ buckets and no single worker hogs them. A -non-positive @liveWorkers@ is treated as one (claim everything). --} +-- | The fair-share claim target: @ceil(N / liveWorkers)@. When @k@ workers are +-- live they collectively claim all @N@ buckets and no single worker hogs them. A +-- non-positive @liveWorkers@ is treated as one (claim everything). fairShareTarget :: Int -> Int -> Int fairShareTarget shardCount liveWorkers = - let k = max 1 liveWorkers - in (shardCount + k - 1) `div` k + let k = max 1 liveWorkers + in (shardCount + k - 1) `div` k -{- | Idempotently populate the @N@ shard rows for this subscription. Safe to call -on every worker startup ('ensureShardRows' uses @ON CONFLICT DO NOTHING@). --} +-- | Idempotently populate the @N@ shard rows for this subscription. Safe to call +-- on every worker startup ('ensureShardRows' uses @ON CONFLICT DO NOTHING@). ensureShards :: (Store :> es) => ShardLease -> Eff es () ensureShards lease = do - counts <- runTransaction $ do - ensureShardRows (subscriptionName lease) (shardCount lease) - listShardCounts (subscriptionName lease) - let configured = shardCount lease - found = [n | (n, _) <- counts, n /= configured] - unless (null found) $ - throwIO - ShardCountMismatch - { mismatchSubscriptionName = case subscriptionName lease of - SubscriptionName name -> name - , mismatchConfigured = configured - , mismatchFound = found - } - -{- | One ownership-reconcile pass: in a single transaction, renew the leases this -worker still holds, then — if it holds fewer than its fair share — claim __one__ -more bucket (unowned or expired). Returns the set of buckets owned __after__ the -pass. - -Claiming __one at a time__ is deliberate and is what makes a pool of identical -workers converge to a fair split without any external coordinator. If a cold -worker grabbed its whole fair share at once it could, racing alone before its -peers' first pass, monopolise every bucket and then never see the idle peers -(they own nothing, so they are invisible in the lease table). Taking one bucket -per pass instead means concurrently-starting workers each grab one, become -visible after the first pass, and climb to an even share together; a worker -joining a balanced pool only picks up buckets freed by an expired lease -(failover). Ownership spreads over up to @N@ reconcile intervals — a deliberate -trade of spin-up latency for coordinator-free fairness. + counts <- runTransaction $ do + ensureShardRows (subscriptionName lease) (shardCount lease) + listShardCounts (subscriptionName lease) + let configured = shardCount lease + found = [n | (n, _) <- counts, n /= configured] + unless (null found) $ + throwIO + ShardCountMismatch + { mismatchSubscriptionName = case subscriptionName lease of + SubscriptionName name -> name, + mismatchConfigured = configured, + mismatchFound = found + } -@liveWorkers@ is the caller's estimate of how many workers are currently live -(see 'ownershipSnapshot'); it tunes the fair-share target and self-corrects next -pass. It never causes double ownership, because the @FOR UPDATE SKIP LOCKED@ -claim is the real exclusion mechanism. --} +-- | One ownership-reconcile pass: in a single transaction, renew the leases this +-- worker still holds, then — if it holds fewer than its fair share — claim __one__ +-- more bucket (unowned or expired). Returns the set of buckets owned __after__ the +-- pass. +-- +-- Claiming __one at a time__ is deliberate and is what makes a pool of identical +-- workers converge to a fair split without any external coordinator. If a cold +-- worker grabbed its whole fair share at once it could, racing alone before its +-- peers' first pass, monopolise every bucket and then never see the idle peers +-- (they own nothing, so they are invisible in the lease table). Taking one bucket +-- per pass instead means concurrently-starting workers each grab one, become +-- visible after the first pass, and climb to an even share together; a worker +-- joining a balanced pool only picks up buckets freed by an expired lease +-- (failover). Ownership spreads over up to @N@ reconcile intervals — a deliberate +-- trade of spin-up latency for coordinator-free fairness. +-- +-- @liveWorkers@ is the caller's estimate of how many workers are currently live +-- (see 'ownershipSnapshot'); it tunes the fair-share target and self-corrects next +-- pass. It never causes double ownership, because the @FOR UPDATE SKIP LOCKED@ +-- claim is the real exclusion mechanism. acquireOwnedBuckets :: (IOE :> es, Store :> es) => ShardLease -> Int -> Eff es (Set Int) acquireOwnedBuckets lease liveWorkers = do - now <- liftIO getCurrentTime - let target = fairShareTarget (shardCount lease) liveWorkers - runTransaction $ do - held <- renewLeaseTx (subscriptionName lease) (workerId lease) now (leaseTtl lease) - -- Claim at most one bucket per pass (see the note above on convergence). - claimed <- - if length held < target - then claimShardsTx (subscriptionName lease) (workerId lease) 1 now (leaseTtl lease) - else pure [] - pure (Set.fromList held <> Set.fromList claimed) + now <- liftIO getCurrentTime + let target = fairShareTarget (shardCount lease) liveWorkers + runTransaction $ do + held <- renewLeaseTx (subscriptionName lease) (workerId lease) now (leaseTtl lease) + -- Claim at most one bucket per pass (see the note above on convergence). + claimed <- + if length held < target + then claimShardsTx (subscriptionName lease) (workerId lease) 1 now (leaseTtl lease) + else pure [] + pure (Set.fromList held <> Set.fromList claimed) -{- | Renew only — write a fresh expiry for every bucket this worker still holds -and return them. Used when a worker wants to heartbeat without claiming more. --} +-- | Renew only — write a fresh expiry for every bucket this worker still holds +-- and return them. Used when a worker wants to heartbeat without claiming more. renewOwnedBuckets :: (IOE :> es, Store :> es) => ShardLease -> Eff es (Set Int) renewOwnedBuckets lease = do - now <- liftIO getCurrentTime - held <- runTransaction (renewLeaseTx (subscriptionName lease) (workerId lease) now (leaseTtl lease)) - pure (Set.fromList held) + now <- liftIO getCurrentTime + held <- runTransaction (renewLeaseTx (subscriptionName lease) (workerId lease) now (leaseTtl lease)) + pure (Set.fromList held) -{- | Graceful release of the given buckets (clean shutdown), so they are -claimable immediately instead of after lease expiry. --} +-- | Graceful release of the given buckets (clean shutdown), so they are +-- claimable immediately instead of after lease expiry. relinquish :: (Store :> es) => ShardLease -> Set Int -> Eff es () relinquish lease buckets = - runTransaction (releaseShardsTx (subscriptionName lease) (workerId lease) (Set.toList buckets)) + runTransaction (releaseShardsTx (subscriptionName lease) (workerId lease) (Set.toList buckets)) -{- | Read every bucket's @(bucket, owner, lease_expires_at)@ for this -subscription. The worker uses it to estimate @liveWorkers@ (count of distinct -non-expired owners) before an 'acquireOwnedBuckets' pass. --} +-- | Read every bucket's @(bucket, owner, lease_expires_at)@ for this +-- subscription. The worker uses it to estimate @liveWorkers@ (count of distinct +-- non-expired owners) before an 'acquireOwnedBuckets' pass. ownershipSnapshot :: - (Store :> es) => ShardLease -> Eff es [(Int, Maybe WorkerId, Maybe UTCTime)] + (Store :> es) => ShardLease -> Eff es [(Int, Maybe WorkerId, Maybe UTCTime)] ownershipSnapshot lease = - runTransaction (listShardOwnership (subscriptionName lease)) + runTransaction (listShardOwnership (subscriptionName lease)) diff --git a/src/Keiro/Subscription/Shard/Schema.hs b/src/Keiro/Subscription/Shard/Schema.hs --- a/src/Keiro/Subscription/Shard/Schema.hs +++ b/src/Keiro/Subscription/Shard/Schema.hs @@ -1,28 +1,27 @@ -{- | The @keiro_subscription_shards@ table: storage and lease logic for -cooperative consumer-group ownership (EP-51). - -A category subscription can be split across @N@ buckets — kiroku consumer-group -member indices in @[0, N)@ — so that @N@ cooperating workers each drain a -disjoint slice of the keyspace. This module owns the durable __assignment__ -layer: one row per @(subscription_name, bucket)@ recording which worker holds it -right now, as a renewable __lease__ (an owner id plus an expiry timestamp). A -live worker renews its lease on a heartbeat; a dead worker stops renewing, its -lease expires, and another worker re-claims the bucket (failover). It does -__not__ store event positions — kiroku's per-member checkpoints -(@(subscription_name, consumer_group_member)@) do that, so a re-homed bucket -resumes where its previous owner left off. - -The statements here are 'Hasql.Transaction.Transaction'-flavoured so callers can -compose several into one short transaction (e.g. renew-then-claim in -'Keiro.Subscription.Shard.acquireOwnedBuckets'); the typed 'Eff'-level wrappers -that run them through kiroku's pool live in "Keiro.Subscription.Shard". The -claim uses @FOR UPDATE SKIP LOCKED@ over the claimable rows, exactly as -'Keiro.Timer.Schema.claimDueTimer' does, so two workers racing the same bucket -can never both win — a stale "how many workers are live" estimate only changes -how aggressively a worker claims, never whether ownership stays disjoint. --} -module Keiro.Subscription.Shard.Schema ( - -- * Worker identity +-- | The @keiro_subscription_shards@ table: storage and lease logic for +-- cooperative consumer-group ownership (EP-51). +-- +-- A category subscription can be split across @N@ buckets — kiroku consumer-group +-- member indices in @[0, N)@ — so that @N@ cooperating workers each drain a +-- disjoint slice of the keyspace. This module owns the durable __assignment__ +-- layer: one row per @(subscription_name, bucket)@ recording which worker holds it +-- right now, as a renewable __lease__ (an owner id plus an expiry timestamp). A +-- live worker renews its lease on a heartbeat; a dead worker stops renewing, its +-- lease expires, and another worker re-claims the bucket (failover). It does +-- __not__ store event positions — kiroku's per-member checkpoints +-- (@(subscription_name, consumer_group_member)@) do that, so a re-homed bucket +-- resumes where its previous owner left off. +-- +-- The statements here are 'Hasql.Transaction.Transaction'-flavoured so callers can +-- compose several into one short transaction (e.g. renew-then-claim in +-- 'Keiro.Subscription.Shard.acquireOwnedBuckets'); the typed 'Eff'-level wrappers +-- that run them through kiroku's pool live in "Keiro.Subscription.Shard". The +-- claim uses @FOR UPDATE SKIP LOCKED@ over the claimable rows, exactly as +-- 'Keiro.Timer.Schema.claimDueTimer' does, so two workers racing the same bucket +-- can never both win — a stale "how many workers are live" estimate only changes +-- how aggressively a worker claims, never whether ownership stays disjoint. +module Keiro.Subscription.Shard.Schema + ( -- * Worker identity WorkerId (..), -- * Lease statements (composable within a transaction) @@ -32,7 +31,7 @@ releaseShardsTx, listShardOwnership, listShardCounts, -) + ) where import Contravariant.Extras (contrazip2, contrazip3, contrazip4, contrazip5) @@ -46,182 +45,176 @@ import Kiroku.Store.Subscription.Types (SubscriptionName (..)) import "hasql-transaction" Hasql.Transaction qualified as Tx -{- | A per-process unique id naming the owner in a lease row. A UUID minted once -at worker start ('Keiro.Subscription.Shard.freshWorkerId'); two restarts of the -same binary get two different ids, so a restarted process never inherits the -dead process's leases — it claims afresh once the old leases expire. --} +-- | A per-process unique id naming the owner in a lease row. A UUID minted once +-- at worker start ('Keiro.Subscription.Shard.freshWorkerId'); two restarts of the +-- same binary get two different ids, so a restarted process never inherits the +-- dead process's leases — it claims afresh once the old leases expire. newtype WorkerId = WorkerId UUID - deriving stock (Eq, Ord, Show) + deriving stock (Eq, Ord, Show) -{- | Idempotently insert the @N@ rows @(name, bucket = 0..N-1, shard_count = N)@ -with @owner_worker_id@ left @NULL@. @ON CONFLICT DO NOTHING@ makes calling it -on every worker startup safe; it converges the table to exactly @N@ rows. --} +-- | Idempotently insert the @N@ rows @(name, bucket = 0..N-1, shard_count = N)@ +-- with @owner_worker_id@ left @NULL@. @ON CONFLICT DO NOTHING@ makes calling it +-- on every worker startup safe; it converges the table to exactly @N@ rows. ensureShardRows :: SubscriptionName -> Int -> Tx.Transaction () ensureShardRows (SubscriptionName name) shardCount = - Tx.statement (name, fromIntegral shardCount) ensureShardRowsStmt + Tx.statement (name, fromIntegral shardCount) ensureShardRowsStmt -{- | Claim up to @targetCount@ buckets that are currently unowned __or__ whose -lease has expired (@owner_worker_id IS NULL OR lease_expires_at < now@), in one -statement, returning the bucket numbers actually claimed. @FOR UPDATE SKIP -LOCKED@ over the claimable rows is the exclusion mechanism: two workers racing -the same bucket cannot both win. The TTL is added to @now@ here (in Haskell) to -form the new @lease_expires_at@. --} +-- | Claim up to @targetCount@ buckets that are currently unowned __or__ whose +-- lease has expired (@owner_worker_id IS NULL OR lease_expires_at < now@), in one +-- statement, returning the bucket numbers actually claimed. @FOR UPDATE SKIP +-- LOCKED@ over the claimable rows is the exclusion mechanism: two workers racing +-- the same bucket cannot both win. The TTL is added to @now@ here (in Haskell) to +-- form the new @lease_expires_at@. claimShardsTx :: - SubscriptionName -> WorkerId -> Int -> UTCTime -> NominalDiffTime -> Tx.Transaction [Int] + SubscriptionName -> WorkerId -> Int -> UTCTime -> NominalDiffTime -> Tx.Transaction [Int] claimShardsTx (SubscriptionName name) (WorkerId worker) targetCount now ttl = - fmap (fmap fromIntegral) $ - Tx.statement - (name, now, addUTCTime ttl now, worker, fromIntegral targetCount) - claimShardsStmt + fmap (fmap fromIntegral) $ + Tx.statement + (name, now, addUTCTime ttl now, worker, fromIntegral targetCount) + claimShardsStmt -{- | Renew every lease this worker still holds: write a fresh @lease_expires_at = -now + ttl@ and @heartbeat_at = now@ for each row it owns, returning the buckets -still held. A bucket stolen after this worker's lease lapsed is owned by someone -else and so is __not__ in the result — that is how a worker learns it lost a -bucket and stops reading it. --} +-- | Renew every lease this worker still holds: write a fresh @lease_expires_at = +-- now + ttl@ and @heartbeat_at = now@ for each row it owns, returning the buckets +-- still held. A bucket stolen after this worker's lease lapsed is owned by someone +-- else and so is __not__ in the result — that is how a worker learns it lost a +-- bucket and stops reading it. renewLeaseTx :: SubscriptionName -> WorkerId -> UTCTime -> NominalDiffTime -> Tx.Transaction [Int] renewLeaseTx (SubscriptionName name) (WorkerId worker) now ttl = - fmap (fmap fromIntegral) $ - Tx.statement (name, now, addUTCTime ttl now, worker) renewLeaseStmt + fmap (fmap fromIntegral) $ + Tx.statement (name, now, addUTCTime ttl now, worker) renewLeaseStmt -{- | Graceful relinquish: clear ownership of the given buckets this worker holds -so they become claimable immediately, without waiting for lease expiry. Called -on clean shutdown. Only rows still owned by @worker@ are affected, so a bucket -already stolen is left untouched. --} +-- | Graceful relinquish: clear ownership of the given buckets this worker holds +-- so they become claimable immediately, without waiting for lease expiry. Called +-- on clean shutdown. Only rows still owned by @worker@ are affected, so a bucket +-- already stolen is left untouched. releaseShardsTx :: SubscriptionName -> WorkerId -> [Int] -> Tx.Transaction () releaseShardsTx (SubscriptionName name) (WorkerId worker) buckets = - Tx.statement (name, worker, fmap fromIntegral buckets) releaseShardsStmt + Tx.statement (name, worker, fmap fromIntegral buckets) releaseShardsStmt -{- | Observability/test read of @(bucket, owner, lease_expires_at)@ for one -subscription, ordered by bucket. --} +-- | Observability/test read of @(bucket, owner, lease_expires_at)@ for one +-- subscription, ordered by bucket. listShardOwnership :: SubscriptionName -> Tx.Transaction [(Int, Maybe WorkerId, Maybe UTCTime)] listShardOwnership (SubscriptionName name) = - Tx.statement name listShardOwnershipStmt + Tx.statement name listShardOwnershipStmt -- | Read existing shard-count groups for a subscription as @(shard_count, rows)@. listShardCounts :: SubscriptionName -> Tx.Transaction [(Int, Int)] listShardCounts (SubscriptionName name) = - Tx.statement name listShardCountsStmt + Tx.statement name listShardCountsStmt ensureShardRowsStmt :: Statement (Text, Int32) () ensureShardRowsStmt = - preparable - """ - INSERT INTO keiro.keiro_subscription_shards (subscription_name, bucket, shard_count) - SELECT $1, g, $2 - FROM generate_series(0, $2 - 1) AS g - ON CONFLICT (subscription_name, bucket) DO NOTHING - """ - ( contrazip2 - (E.param (E.nonNullable E.text)) - (E.param (E.nonNullable E.int4)) - ) - D.noResult + preparable + """ + INSERT INTO keiro.keiro_subscription_shards (subscription_name, bucket, shard_count) + SELECT $1, g, $2 + FROM generate_series(0, $2 - 1) AS g + ON CONFLICT (subscription_name, bucket) DO NOTHING + """ + ( contrazip2 + (E.param (E.nonNullable E.text)) + (E.param (E.nonNullable E.int4)) + ) + D.noResult claimShardsStmt :: Statement (Text, UTCTime, UTCTime, UUID, Int32) [Int32] claimShardsStmt = - preparable - """ - WITH claimable AS ( - SELECT bucket - FROM keiro.keiro_subscription_shards - WHERE subscription_name = $1 - AND (owner_worker_id IS NULL OR lease_expires_at < $2) - ORDER BY bucket - LIMIT $5 - FOR UPDATE SKIP LOCKED - ) - UPDATE keiro.keiro_subscription_shards s - SET owner_worker_id = $4, - lease_expires_at = $3, - heartbeat_at = $2, - updated_at = $2 - FROM claimable c - WHERE s.subscription_name = $1 AND s.bucket = c.bucket - RETURNING s.bucket - """ - ( contrazip5 - (E.param (E.nonNullable E.text)) - (E.param (E.nonNullable E.timestamptz)) - (E.param (E.nonNullable E.timestamptz)) - (E.param (E.nonNullable E.uuid)) - (E.param (E.nonNullable E.int4)) - ) - (D.rowList (D.column (D.nonNullable D.int4))) + preparable + """ + WITH claimable AS ( + SELECT bucket + FROM keiro.keiro_subscription_shards + WHERE subscription_name = $1 + AND (owner_worker_id IS NULL OR lease_expires_at < $2) + ORDER BY bucket + LIMIT $5 + FOR UPDATE SKIP LOCKED + ) + UPDATE keiro.keiro_subscription_shards s + SET owner_worker_id = $4, + lease_expires_at = $3, + heartbeat_at = $2, + updated_at = $2 + FROM claimable c + WHERE s.subscription_name = $1 AND s.bucket = c.bucket + RETURNING s.bucket + """ + ( contrazip5 + (E.param (E.nonNullable E.text)) + (E.param (E.nonNullable E.timestamptz)) + (E.param (E.nonNullable E.timestamptz)) + (E.param (E.nonNullable E.uuid)) + (E.param (E.nonNullable E.int4)) + ) + (D.rowList (D.column (D.nonNullable D.int4))) renewLeaseStmt :: Statement (Text, UTCTime, UTCTime, UUID) [Int32] renewLeaseStmt = - preparable - """ - UPDATE keiro.keiro_subscription_shards - SET lease_expires_at = $3, - heartbeat_at = $2, - updated_at = $2 - WHERE subscription_name = $1 - AND owner_worker_id = $4 - RETURNING bucket - """ - ( contrazip4 - (E.param (E.nonNullable E.text)) - (E.param (E.nonNullable E.timestamptz)) - (E.param (E.nonNullable E.timestamptz)) - (E.param (E.nonNullable E.uuid)) - ) - (D.rowList (D.column (D.nonNullable D.int4))) + preparable + """ + UPDATE keiro.keiro_subscription_shards + SET lease_expires_at = $3, + heartbeat_at = $2, + updated_at = $2 + WHERE subscription_name = $1 + AND owner_worker_id = $4 + RETURNING bucket + """ + ( contrazip4 + (E.param (E.nonNullable E.text)) + (E.param (E.nonNullable E.timestamptz)) + (E.param (E.nonNullable E.timestamptz)) + (E.param (E.nonNullable E.uuid)) + ) + (D.rowList (D.column (D.nonNullable D.int4))) releaseShardsStmt :: Statement (Text, UUID, [Int32]) () releaseShardsStmt = - preparable - """ - UPDATE keiro.keiro_subscription_shards - SET owner_worker_id = NULL, - lease_expires_at = NULL, - updated_at = now() - WHERE subscription_name = $1 - AND owner_worker_id = $2 - AND bucket = ANY($3) - """ - ( contrazip3 - (E.param (E.nonNullable E.text)) - (E.param (E.nonNullable E.uuid)) - (E.param (E.nonNullable (E.foldableArray (E.nonNullable E.int4)))) - ) - D.noResult + preparable + """ + UPDATE keiro.keiro_subscription_shards + SET owner_worker_id = NULL, + lease_expires_at = NULL, + updated_at = now() + WHERE subscription_name = $1 + AND owner_worker_id = $2 + AND bucket = ANY($3) + """ + ( contrazip3 + (E.param (E.nonNullable E.text)) + (E.param (E.nonNullable E.uuid)) + (E.param (E.nonNullable (E.foldableArray (E.nonNullable E.int4)))) + ) + D.noResult listShardOwnershipStmt :: Statement Text [(Int, Maybe WorkerId, Maybe UTCTime)] listShardOwnershipStmt = - preparable - """ - SELECT bucket, owner_worker_id, lease_expires_at - FROM keiro.keiro_subscription_shards - WHERE subscription_name = $1 - ORDER BY bucket - """ - (E.param (E.nonNullable E.text)) - (D.rowList ownershipRowDecoder) + preparable + """ + SELECT bucket, owner_worker_id, lease_expires_at + FROM keiro.keiro_subscription_shards + WHERE subscription_name = $1 + ORDER BY bucket + """ + (E.param (E.nonNullable E.text)) + (D.rowList ownershipRowDecoder) listShardCountsStmt :: Statement Text [(Int, Int)] listShardCountsStmt = - preparable - """ - SELECT shard_count, count(*)::int - FROM keiro.keiro_subscription_shards - WHERE subscription_name = $1 - GROUP BY shard_count - ORDER BY shard_count - """ - (E.param (E.nonNullable E.text)) - (D.rowList ((,) <$> (fromIntegral <$> D.column (D.nonNullable D.int4)) <*> (fromIntegral <$> D.column (D.nonNullable D.int4)))) + preparable + """ + SELECT shard_count, count(*)::int + FROM keiro.keiro_subscription_shards + WHERE subscription_name = $1 + GROUP BY shard_count + ORDER BY shard_count + """ + (E.param (E.nonNullable E.text)) + (D.rowList ((,) <$> (fromIntegral <$> D.column (D.nonNullable D.int4)) <*> (fromIntegral <$> D.column (D.nonNullable D.int4)))) ownershipRowDecoder :: D.Row (Int, Maybe WorkerId, Maybe UTCTime) ownershipRowDecoder = - (,,) - <$> (fromIntegral <$> D.column (D.nonNullable D.int4)) - <*> (fmap WorkerId <$> D.column (D.nullable D.uuid)) - <*> D.column (D.nullable D.timestamptz) + (,,) + <$> (fromIntegral <$> D.column (D.nonNullable D.int4)) + <*> (fmap WorkerId <$> D.column (D.nullable D.uuid)) + <*> D.column (D.nullable D.timestamptz) diff --git a/src/Keiro/Subscription/Shard/Worker.hs b/src/Keiro/Subscription/Shard/Worker.hs --- a/src/Keiro/Subscription/Shard/Worker.hs +++ b/src/Keiro/Subscription/Shard/Worker.hs @@ -1,69 +1,68 @@ -{- | The sharded category-subscription worker: a rebalance loop that turns -leased bucket ownership ("Keiro.Subscription.Shard") into running kiroku -consumer-group readers (EP-51). - -Start the __same__ worker binary @N@ times — on @N@ hosts, in @N@ containers, in -an autoscaling group — each calling 'runShardedSubscriptionGroup' with the same -'SubscriptionName' and 'ShardedWorkerOptions', and the workers cooperatively -partition the category among themselves: every event is processed at least once -and none are skipped. A brief ownership overlap can deliver an event more than -once, so handlers must be idempotent. No external coordinator -(etcd/ZooKeeper/Consul) — coordination lives in the -@keiro_subscription_shards@ lease table. - -== One pass - -'reconcileShardsOnce' is the single testable unit (like -'Keiro.Workflow.Resume.resumeWorkflowsOnce'): - -1. Estimate how many workers are live from the lease table. -2. 'Keiro.Subscription.Shard.acquireOwnedBuckets' — renew the leases this worker - still holds and claim up to a fair share more (taking over expired leases). -3. __Shed__ any buckets held beyond the fair share when more than one worker is - live, so a worker that grabbed too many on a cold start (when it briefly - believed it was alone) gives the excess back and the pool converges to an - even split. A lone worker never sheds — it must own every bucket. -4. Reconcile readers: open a kiroku consumer-group reader for each newly-owned - bucket, stop the reader for each newly-lost bucket. A bucket that moves owners - resumes at its own kiroku per-member checkpoint. Each event is acknowledged - only after its handler returns, so a shed bucket's checkpoint never covers an - unprocessed event and no event is dropped. - -'runShardedSubscriptionGroup' is the loop driver: mint a 'WorkerId', ensure the -shard rows exist, then run 'reconcileShardsOnce' every @renewInterval@ forever. -On graceful shutdown (the loop thread is killed and can run cleanup) a @finally@ -stops every reader this worker holds and relinquishes its leases so another -worker can claim immediately. A real process crash still recovers by lease -expiry. - -== Why @IO@, not @Eff@ - -Like 'Keiro.Workflow.Resume.runWorkflowResumeWorkerPush', this worker manages -long-lived 'Control.Concurrent' reader threads and takes the 'KirokuStore' handle -directly (each lease pass runs through 'Kiroku.Store.Effect.runStoreIO'), so its -natural home is 'IO'. The compatibility handler is an ordinary -@'RecordedEvent' -> 'IO' ()@; 'runShardedSubscriptionGroupAck' exposes the -per-event 'ShardAck' surface for handlers that need an explicit retry or -dead-letter decision. A sharded subscription delivers at-least-once (a brief -overlap is possible while a bucket changes owners), so the handler must be -idempotent — keyed on @eventId@ — exactly as keiro's async-projection guidance -already requires. - -A synchronous exception from either handler is retried in place according to -'retryPolicy', using 'handlerRetryDelay'. Exhausting the bounded delivery budget -records the event in kiroku's @kiroku.dead_letters@ table and advances to the next -event. 'ShardReaderDied' therefore reports stream-level failures, not ordinary -handler exceptions. An asynchronous exception from shedding or shutdown writes -no acknowledgement, so the event is redelivered by the next owner. - -A zombie worker that misses renewals past @leaseTtl@ may continue reading briefly -after another worker claims its bucket, which can duplicate deliveries. It cannot -regress the consumer-group checkpoint: kiroku's checkpoint upsert is monotonic -(@GREATEST@), so a late acknowledgement from the laggard never moves progress -backward. --} -module Keiro.Subscription.Shard.Worker ( - -- * Options +-- | The sharded category-subscription worker: a rebalance loop that turns +-- leased bucket ownership ("Keiro.Subscription.Shard") into running kiroku +-- consumer-group readers (EP-51). +-- +-- Start the __same__ worker binary @N@ times — on @N@ hosts, in @N@ containers, in +-- an autoscaling group — each calling 'runShardedSubscriptionGroup' with the same +-- 'SubscriptionName' and 'ShardedWorkerOptions', and the workers cooperatively +-- partition the category among themselves: every event is processed at least once +-- and none are skipped. A brief ownership overlap can deliver an event more than +-- once, so handlers must be idempotent. No external coordinator +-- (etcd/ZooKeeper/Consul) — coordination lives in the +-- @keiro_subscription_shards@ lease table. +-- +-- == One pass +-- +-- 'reconcileShardsOnce' is the single testable unit (like +-- 'Keiro.Workflow.Resume.resumeWorkflowsOnce'): +-- +-- 1. Estimate how many workers are live from the lease table. +-- 2. 'Keiro.Subscription.Shard.acquireOwnedBuckets' — renew the leases this worker +-- still holds and claim up to a fair share more (taking over expired leases). +-- 3. __Shed__ any buckets held beyond the fair share when more than one worker is +-- live, so a worker that grabbed too many on a cold start (when it briefly +-- believed it was alone) gives the excess back and the pool converges to an +-- even split. A lone worker never sheds — it must own every bucket. +-- 4. Reconcile readers: open a kiroku consumer-group reader for each newly-owned +-- bucket, stop the reader for each newly-lost bucket. A bucket that moves owners +-- resumes at its own kiroku per-member checkpoint. Each event is acknowledged +-- only after its handler returns, so a shed bucket's checkpoint never covers an +-- unprocessed event and no event is dropped. +-- +-- 'runShardedSubscriptionGroup' is the loop driver: mint a 'WorkerId', ensure the +-- shard rows exist, then run 'reconcileShardsOnce' every @renewInterval@ forever. +-- On graceful shutdown (the loop thread is killed and can run cleanup) a @finally@ +-- stops every reader this worker holds and relinquishes its leases so another +-- worker can claim immediately. A real process crash still recovers by lease +-- expiry. +-- +-- == Why @IO@, not @Eff@ +-- +-- Like 'Keiro.Workflow.Resume.runWorkflowResumeWorkerPush', this worker manages +-- long-lived 'Control.Concurrent' reader threads and takes the 'KirokuStore' handle +-- directly (each lease pass runs through 'Kiroku.Store.Effect.runStoreIO'), so its +-- natural home is 'IO'. The compatibility handler is an ordinary +-- @'RecordedEvent' -> 'IO' ()@; 'runShardedSubscriptionGroupAck' exposes the +-- per-event 'ShardAck' surface for handlers that need an explicit retry or +-- dead-letter decision. A sharded subscription delivers at-least-once (a brief +-- overlap is possible while a bucket changes owners), so the handler must be +-- idempotent — keyed on @eventId@ — exactly as keiro's async-projection guidance +-- already requires. +-- +-- A synchronous exception from either handler is retried in place according to +-- 'retryPolicy', using 'handlerRetryDelay'. Exhausting the bounded delivery budget +-- records the event in kiroku's @kiroku.dead_letters@ table and advances to the next +-- event. 'ShardReaderDied' therefore reports stream-level failures, not ordinary +-- handler exceptions. An asynchronous exception from shedding or shutdown writes +-- no acknowledgement, so the event is redelivered by the next owner. +-- +-- A zombie worker that misses renewals past @leaseTtl@ may continue reading briefly +-- after another worker claims its bucket, which can duplicate deliveries. It cannot +-- regress the consumer-group checkpoint: kiroku's checkpoint upsert is monotonic +-- (@GREATEST@), so a late acknowledgement from the laggard never moves progress +-- backward. +module Keiro.Subscription.Shard.Worker + ( -- * Options ShardWorkerError (..), ShardedWorkerOptions (..), ShardedWorkerConfigError (..), @@ -82,7 +81,7 @@ reconcileShardsOnce, runShardedSubscriptionGroup, runShardedSubscriptionGroupAck, -) + ) where import Control.Concurrent (forkFinally, killThread, threadDelay) @@ -101,20 +100,20 @@ import Data.Time (NominalDiffTime) import Data.UUID.V4 qualified as UUIDv4 import Keiro.Prelude -import Keiro.Subscription.Shard ( - ShardLease (..), +import Keiro.Subscription.Shard + ( ShardLease (..), WorkerId (..), acquireOwnedBuckets, ensureShards, fairShareTarget, ownershipSnapshot, relinquish, - ) + ) import Kiroku.Store.Connection (KirokuStore) import Kiroku.Store.Effect (runStoreIO) import Kiroku.Store.Subscription.Stream (AckItem (..), subscriptionAckStream) -import Kiroku.Store.Subscription.Types ( - ConsumerGroup (..), +import Kiroku.Store.Subscription.Types + ( ConsumerGroup (..), DeadLetterReason (..), RetryDelay (..), RetryPolicy (..), @@ -123,7 +122,7 @@ SubscriptionTarget, defaultRetryPolicy, defaultSubscriptionConfig, - ) + ) import Kiroku.Store.Subscription.Types qualified as Sub import Kiroku.Store.Types (RecordedEvent) import Numeric.Natural (Natural) @@ -131,298 +130,291 @@ import Streamly.Data.Stream qualified as Stream data ShardWorkerError - = ShardSnapshotFailed !Text - | ShardAcquireFailed !Text - | ShardReaderDied !Int !Text - | ShardEnsureFailed !Text - deriving stock (Generic, Eq, Show) + = ShardSnapshotFailed !Text + | ShardAcquireFailed !Text + | ShardReaderDied !Int !Text + | ShardEnsureFailed !Text + deriving stock (Generic, Eq, Show) -- | Per-event disposition returned by an acknowledgement-aware shard handler. data ShardAck - = -- | Processing completed; the checkpoint may advance past this event. - ShardAckOk - | -- | Redeliver after the delay, bounded by 'retryPolicy'. - ShardAckRetry !RetryDelay - | -- | Record the event in kiroku's dead-letter table and advance immediately. - ShardAckDeadLetter !DeadLetterReason - deriving stock (Generic, Eq, Show) + = -- | Processing completed; the checkpoint may advance past this event. + ShardAckOk + | -- | Redeliver after the delay, bounded by 'retryPolicy'. + ShardAckRetry !RetryDelay + | -- | Record the event in kiroku's dead-letter table and advance immediately. + ShardAckDeadLetter !DeadLetterReason + deriving stock (Generic, Eq, Show) -- | One delivery to an acknowledgement-aware shard handler. data ShardDelivery = ShardDelivery - { event :: !RecordedEvent - -- ^ The delivered event. - , attempt :: !Word - -- ^ Zero-based redelivery count: 0 initially, 1 after the first retry, and so on. - , bucket :: !Int - -- ^ The consumer-group member owned by this reader. - } - deriving stock (Generic, Eq, Show) + { -- | The delivered event. + event :: !RecordedEvent, + -- | Zero-based redelivery count: 0 initially, 1 after the first retry, and so on. + attempt :: !Word, + -- | The consumer-group member owned by this reader. + bucket :: !Int + } + deriving stock (Generic, Eq, Show) type ShardEventHandler = ShardDelivery -> IO ShardAck -- | How a sharded worker pool runs one subscription. data ShardedWorkerOptions = ShardedWorkerOptions - { shardCount :: !Int - -- ^ @N@ buckets, fixed per subscription name (every worker must agree on @N@). - , leaseTtl :: !NominalDiffTime - -- ^ How long a claim/renew keeps a bucket before it expires (default 30 s). - , renewInterval :: !NominalDiffTime - {- ^ Gap between reconcile passes; well under 'leaseTtl' so a live worker renews - several times per TTL (default 10 s ⇒ ~3 renews per 30 s TTL). A single - missed renewal does not lose ownership; a dead worker loses every bucket - within one TTL. - -} - , target :: !SubscriptionTarget - -- ^ The category (or @AllStreams@) to shard. - , batchSize :: !Int32 - -- ^ Events per database fetch per bucket reader (default 100). - , bufferSize :: !Natural - -- ^ Per-reader bridge queue capacity (default 256; one item is in flight). - , handlerRetryDelay :: !RetryDelay - -- ^ Delay before redelivering after a synchronous handler exception (default 1 s). - , retryPolicy :: !RetryPolicy - -- ^ Maximum total deliveries before retry exhaustion dead-letters the event. - , onShardError :: !(Maybe (ShardWorkerError -> IO ())) - -- ^ Optional error hook. Wire this to the application logger in production. - } - deriving stock (Generic) + { -- | @N@ buckets, fixed per subscription name (every worker must agree on @N@). + shardCount :: !Int, + -- | How long a claim/renew keeps a bucket before it expires (default 30 s). + leaseTtl :: !NominalDiffTime, + -- | Gap between reconcile passes; well under 'leaseTtl' so a live worker renews + -- several times per TTL (default 10 s ⇒ ~3 renews per 30 s TTL). A single + -- missed renewal does not lose ownership; a dead worker loses every bucket + -- within one TTL. + renewInterval :: !NominalDiffTime, + -- | The category (or @AllStreams@) to shard. + target :: !SubscriptionTarget, + -- | Events per database fetch per bucket reader (default 100). + batchSize :: !Int32, + -- | Per-reader bridge queue capacity (default 256; one item is in flight). + bufferSize :: !Natural, + -- | Delay before redelivering after a synchronous handler exception (default 1 s). + handlerRetryDelay :: !RetryDelay, + -- | Maximum total deliveries before retry exhaustion dead-letters the event. + retryPolicy :: !RetryPolicy, + -- | Optional error hook. Wire this to the application logger in production. + onShardError :: !(Maybe (ShardWorkerError -> IO ())) + } + deriving stock (Generic) data ShardedWorkerConfigError - = InvalidShardCount !Int - | InvalidShardLeaseTtl !NominalDiffTime - | InvalidShardRenewInterval !NominalDiffTime - | InvalidShardLeaseRenewInterval !NominalDiffTime !NominalDiffTime - | InvalidShardBatchSize !Int32 - | InvalidShardBufferSize !Natural - | InvalidShardHandlerRetryDelay !RetryDelay - | InvalidShardRetryMaxAttempts !Int - deriving stock (Generic, Eq, Show) + = InvalidShardCount !Int + | InvalidShardLeaseTtl !NominalDiffTime + | InvalidShardRenewInterval !NominalDiffTime + | InvalidShardLeaseRenewInterval !NominalDiffTime !NominalDiffTime + | InvalidShardBatchSize !Int32 + | InvalidShardBufferSize !Natural + | InvalidShardHandlerRetryDelay !RetryDelay + | InvalidShardRetryMaxAttempts !Int + deriving stock (Generic, Eq, Show) -{- | Sensible defaults for a sharded worker: 30 s lease, 10 s renew, batch 100, -buffer 256. Supply the category target and the bucket count @N@. --} +-- | Sensible defaults for a sharded worker: 30 s lease, 10 s renew, batch 100, +-- buffer 256. Supply the category target and the bucket count @N@. defaultShardedWorkerOptions :: SubscriptionTarget -> Int -> ShardedWorkerOptions defaultShardedWorkerOptions target' shardCount' = - ShardedWorkerOptions - { shardCount = shardCount' - , leaseTtl = 30 - , renewInterval = 10 - , target = target' - , batchSize = 100 - , bufferSize = 256 - , handlerRetryDelay = RetryDelay 1 - , retryPolicy = defaultRetryPolicy - , onShardError = Nothing - } + ShardedWorkerOptions + { shardCount = shardCount', + leaseTtl = 30, + renewInterval = 10, + target = target', + batchSize = 100, + bufferSize = 256, + handlerRetryDelay = RetryDelay 1, + retryPolicy = defaultRetryPolicy, + onShardError = Nothing + } -- | Validate sharded worker options before starting a worker pool member. mkShardedWorkerOptions :: ShardedWorkerOptions -> Either ShardedWorkerConfigError ShardedWorkerOptions mkShardedWorkerOptions opts - | opts ^. #shardCount < 1 = Left (InvalidShardCount (opts ^. #shardCount)) - | opts ^. #leaseTtl <= 0 = Left (InvalidShardLeaseTtl (opts ^. #leaseTtl)) - | opts ^. #renewInterval <= 0 = Left (InvalidShardRenewInterval (opts ^. #renewInterval)) - | opts ^. #leaseTtl <= opts ^. #renewInterval = - Left (InvalidShardLeaseRenewInterval (opts ^. #leaseTtl) (opts ^. #renewInterval)) - | opts ^. #batchSize < 1 = Left (InvalidShardBatchSize (opts ^. #batchSize)) - | opts ^. #bufferSize < 1 = Left (InvalidShardBufferSize (opts ^. #bufferSize)) - | RetryDelay delay <- opts ^. #handlerRetryDelay - , delay < 0 = - Left (InvalidShardHandlerRetryDelay (opts ^. #handlerRetryDelay)) - | RetryPolicy attempts <- opts ^. #retryPolicy - , attempts < 1 = - Left (InvalidShardRetryMaxAttempts attempts) - | otherwise = Right opts + | opts ^. #shardCount < 1 = Left (InvalidShardCount (opts ^. #shardCount)) + | opts ^. #leaseTtl <= 0 = Left (InvalidShardLeaseTtl (opts ^. #leaseTtl)) + | opts ^. #renewInterval <= 0 = Left (InvalidShardRenewInterval (opts ^. #renewInterval)) + | opts ^. #leaseTtl <= opts ^. #renewInterval = + Left (InvalidShardLeaseRenewInterval (opts ^. #leaseTtl) (opts ^. #renewInterval)) + | opts ^. #batchSize < 1 = Left (InvalidShardBatchSize (opts ^. #batchSize)) + | opts ^. #bufferSize < 1 = Left (InvalidShardBufferSize (opts ^. #bufferSize)) + | RetryDelay delay <- opts ^. #handlerRetryDelay, + delay < 0 = + Left (InvalidShardHandlerRetryDelay (opts ^. #handlerRetryDelay)) + | RetryPolicy attempts <- opts ^. #retryPolicy, + attempts < 1 = + Left (InvalidShardRetryMaxAttempts attempts) + | otherwise = Right opts -{- | A live per-bucket reader: the action that stops it (cancels the kiroku -subscription and kills the drain thread). --} +-- | A live per-bucket reader: the action that stops it (cancels the kiroku +-- subscription and kills the drain thread). newtype RunningReader = RunningReader {stopReader :: IO ()} reportShardError :: ShardedWorkerOptions -> ShardWorkerError -> IO () reportShardError opts err = - for_ (opts ^. #onShardError) ($ err) + for_ (opts ^. #onShardError) ($ err) acquireOutcome :: Set Int -> Either Text (Set Int) -> (Set Int, Maybe ShardWorkerError) acquireOutcome previous = \case - Right owned -> (owned, Nothing) - Left err -> (previous, Just (ShardAcquireFailed err)) - -{- | Run one ownership-reconcile pass and bring the set of running readers in -line with the buckets owned afterwards. Returns the buckets this worker owns -after the pass. The @readers@ ref maps each owned bucket to its live reader. + Right owned -> (owned, Nothing) + Left err -> (previous, Just (ShardAcquireFailed err)) -This is the testable unit: a single call claims/renews/sheds leases and -starts/stops readers once, with no loop of its own. --} +-- | Run one ownership-reconcile pass and bring the set of running readers in +-- line with the buckets owned afterwards. Returns the buckets this worker owns +-- after the pass. The @readers@ ref maps each owned bucket to its live reader. +-- +-- This is the testable unit: a single call claims/renews/sheds leases and +-- starts/stops readers once, with no loop of its own. reconcileShardsOnce :: - KirokuStore -> - ShardLease -> - ShardedWorkerOptions -> - IORef (Map Int RunningReader) -> - ShardEventHandler -> - IO (Set Int) + KirokuStore -> + ShardLease -> + ShardedWorkerOptions -> + IORef (Map Int RunningReader) -> + ShardEventHandler -> + IO (Set Int) reconcileShardsOnce store lease opts readers handler = do - now <- getCurrentTime - current <- readIORef readers - -- Estimate live workers: distinct owners with a non-expired lease, plus self. - snapResult <- runStoreIO store (ownershipSnapshot lease) - snap <- case snapResult of - Right rows -> pure rows - Left err -> do - reportShardError opts (ShardSnapshotFailed (Text.pack (show err))) - pure [] - let liveOwners = Set.fromList [w | (_, Just w, Just expiresAt) <- snap, expiresAt > now] - liveWorkers = Set.size (Set.insert (lease ^. #workerId) liveOwners) - shareTarget = fairShareTarget (lease ^. #shardCount) liveWorkers - -- Renew held + claim up to fair share. - claimedResult <- runStoreIO store (acquireOwnedBuckets lease liveWorkers) - let previousOwned = Map.keysSet current - (claimed, mAcquireError) = acquireOutcome previousOwned (first (Text.pack . show) claimedResult) - for_ mAcquireError (reportShardError opts) - -- Shed any excess above the fair share so a cold-start over-claim self-balances - -- (never when alone: a lone worker must own everything). - owned <- - if liveWorkers > 1 && Set.size claimed > shareTarget - then do - let excess = Set.fromList (drop shareTarget (sort (Set.toList claimed))) - _ <- runStoreIO store (relinquish lease excess) - pure (claimed `Set.difference` excess) - else pure claimed - -- Bring readers in line with `owned`: start newly-owned, stop newly-lost. - let running = Map.keysSet current - toStart = owned `Set.difference` running - toStop = running `Set.difference` owned - for_ (Set.toList toStop) $ \bucket -> - for_ (Map.lookup bucket current) stopReader - started <- - traverse - (\bucket -> (,) bucket <$> startReader store lease opts readers handler bucket) - (Set.toList toStart) - atomicModifyIORef' readers $ \m -> - let afterStop = foldr Map.delete m (Set.toList toStop) - afterStart = foldr (\(b, r) -> Map.insert b r) afterStop started - in (afterStart, ()) - pure owned + now <- getCurrentTime + current <- readIORef readers + -- Estimate live workers: distinct owners with a non-expired lease, plus self. + snapResult <- runStoreIO store (ownershipSnapshot lease) + snap <- case snapResult of + Right rows -> pure rows + Left err -> do + reportShardError opts (ShardSnapshotFailed (Text.pack (show err))) + pure [] + let liveOwners = Set.fromList [w | (_, Just w, Just expiresAt) <- snap, expiresAt > now] + liveWorkers = Set.size (Set.insert (lease ^. #workerId) liveOwners) + shareTarget = fairShareTarget (lease ^. #shardCount) liveWorkers + -- Renew held + claim up to fair share. + claimedResult <- runStoreIO store (acquireOwnedBuckets lease liveWorkers) + let previousOwned = Map.keysSet current + (claimed, mAcquireError) = acquireOutcome previousOwned (first (Text.pack . show) claimedResult) + for_ mAcquireError (reportShardError opts) + -- Shed any excess above the fair share so a cold-start over-claim self-balances + -- (never when alone: a lone worker must own everything). + owned <- + if liveWorkers > 1 && Set.size claimed > shareTarget + then do + let excess = Set.fromList (drop shareTarget (sort (Set.toList claimed))) + _ <- runStoreIO store (relinquish lease excess) + pure (claimed `Set.difference` excess) + else pure claimed + -- Bring readers in line with `owned`: start newly-owned, stop newly-lost. + let running = Map.keysSet current + toStart = owned `Set.difference` running + toStop = running `Set.difference` owned + for_ (Set.toList toStop) $ \bucket -> + for_ (Map.lookup bucket current) stopReader + started <- + traverse + (\bucket -> (,) bucket <$> startReader store lease opts readers handler bucket) + (Set.toList toStart) + atomicModifyIORef' readers $ \m -> + let afterStop = foldr Map.delete m (Set.toList toStop) + afterStart = foldr (\(b, r) -> Map.insert b r) afterStop started + in (afterStart, ()) + pure owned -{- | Open a kiroku consumer-group reader for one bucket and fork a thread that -drains it into the handler. The returned 'RunningReader' cancels the -subscription (which terminates the drain) and kills the thread. --} +-- | Open a kiroku consumer-group reader for one bucket and fork a thread that +-- drains it into the handler. The returned 'RunningReader' cancels the +-- subscription (which terminates the drain) and kills the thread. startReader :: - KirokuStore -> - ShardLease -> - ShardedWorkerOptions -> - IORef (Map Int RunningReader) -> - ShardEventHandler -> - Int -> - IO RunningReader + KirokuStore -> + ShardLease -> + ShardedWorkerOptions -> + IORef (Map Int RunningReader) -> + ShardEventHandler -> + Int -> + IO RunningReader startReader store lease opts readers handler bucket = do - stopping <- newIORef False - let subConfig = - (defaultSubscriptionConfig (lease ^. #subscriptionName) (opts ^. #target) (\_ -> pure Continue)) - { Sub.batchSize = opts ^. #batchSize - , Sub.consumerGroup = - Just (ConsumerGroup{member = fromIntegral bucket, size = fromIntegral (opts ^. #shardCount)}) - , Sub.retryPolicy = opts ^. #retryPolicy - } - handleItem item = do - outcome <- - handler - ShardDelivery - { event = ackEvent item - , attempt = ackAttempt item - , bucket = bucket - } - `catch` handlerException - atomically (putTMVar (ackReply item) (toSubscriptionResult outcome)) - handlerException err = - case fromException err of - Just async -> throwIO (async :: SomeAsyncException) - Nothing -> pure (ShardAckRetry (opts ^. #handlerRetryDelay)) - (stream, cancelAction) <- subscriptionAckStream store subConfig (opts ^. #bufferSize) - tid <- - forkFinally (Stream.fold (Fold.drainMapM handleItem) stream) $ \result -> do - intentional <- readIORef stopping - unless intentional $ do - atomicModifyIORef' readers (\m -> (Map.delete bucket m, ())) - let reason = case result of - Left err -> Text.pack (displayException (err :: SomeException)) - Right _ -> "reader stream ended" - reportShardError opts (ShardReaderDied bucket reason) - pure - ( RunningReader $ do - writeIORef stopping True - cancelAction - killThread tid - ) + stopping <- newIORef False + let subConfig = + (defaultSubscriptionConfig (lease ^. #subscriptionName) (opts ^. #target) (\_ -> pure Continue)) + { Sub.batchSize = opts ^. #batchSize, + Sub.consumerGroup = + Just (ConsumerGroup {member = fromIntegral bucket, size = fromIntegral (opts ^. #shardCount)}), + Sub.retryPolicy = opts ^. #retryPolicy + } + handleItem item = do + outcome <- + handler + ShardDelivery + { event = ackEvent item, + attempt = ackAttempt item, + bucket = bucket + } + `catch` handlerException + atomically (putTMVar (ackReply item) (toSubscriptionResult outcome)) + handlerException err = + case fromException err of + Just async -> throwIO (async :: SomeAsyncException) + Nothing -> pure (ShardAckRetry (opts ^. #handlerRetryDelay)) + (stream, cancelAction) <- subscriptionAckStream store subConfig (opts ^. #bufferSize) + tid <- + forkFinally (Stream.fold (Fold.drainMapM handleItem) stream) $ \result -> do + intentional <- readIORef stopping + unless intentional $ do + atomicModifyIORef' readers (\m -> (Map.delete bucket m, ())) + let reason = case result of + Left err -> Text.pack (displayException (err :: SomeException)) + Right _ -> "reader stream ended" + reportShardError opts (ShardReaderDied bucket reason) + pure + ( RunningReader $ do + writeIORef stopping True + cancelAction + killThread tid + ) toSubscriptionResult :: ShardAck -> SubscriptionResult toSubscriptionResult = \case - ShardAckOk -> Continue - ShardAckRetry delay -> Retry delay - ShardAckDeadLetter reason -> DeadLetter reason - -{- | The loop driver: mint a 'WorkerId', ensure the @N@ shard rows exist, then -'reconcileShardsOnce' every @renewInterval@ forever. On shutdown (the loop thread -is killed) a @finally@ stops every reader this worker holds, so a crashed -worker's buckets stop being read immediately; its leases then expire and a -surviving worker re-claims them. + ShardAckOk -> Continue + ShardAckRetry delay -> Retry delay + ShardAckDeadLetter reason -> DeadLetter reason -The fixed @renewInterval@ between passes (the 'threadDelay' in 'loop') is the -__rebalance-signal seam__ (EP-51 Milestone 6). The shipped default is a pure poll: -correctness — disjointness and failover — rests entirely on the lease table and -does not depend on any notification. The EP-50 'Keiro.Wake' channel wakes on event -/appends/ (@kiroku.events@), which is a different event than a shard ownership -/change/; signalling a prompt rebalance on a worker join or a voluntary relinquish -would ride a dedicated @keiro_shard_rebalance@ @NOTIFY@ fired on claim/release, and -the swap is local to this one 'threadDelay' (replace it with a bounded wait on that -channel, exactly as 'Keiro.Workflow.Resume.runPollLoopWith' does for appends). Left -as the poll default here because it is a latency optimisation, not a correctness -requirement. --} +-- | The loop driver: mint a 'WorkerId', ensure the @N@ shard rows exist, then +-- 'reconcileShardsOnce' every @renewInterval@ forever. On shutdown (the loop thread +-- is killed) a @finally@ stops every reader this worker holds, so a crashed +-- worker's buckets stop being read immediately; its leases then expire and a +-- surviving worker re-claims them. +-- +-- The fixed @renewInterval@ between passes (the 'threadDelay' in 'loop') is the +-- __rebalance-signal seam__ (EP-51 Milestone 6). The shipped default is a pure poll: +-- correctness — disjointness and failover — rests entirely on the lease table and +-- does not depend on any notification. The EP-50 'Keiro.Wake' channel wakes on event +-- /appends/ (@kiroku.events@), which is a different event than a shard ownership +-- /change/; signalling a prompt rebalance on a worker join or a voluntary relinquish +-- would ride a dedicated @keiro_shard_rebalance@ @NOTIFY@ fired on claim/release, and +-- the swap is local to this one 'threadDelay' (replace it with a bounded wait on that +-- channel, exactly as 'Keiro.Workflow.Resume.runPollLoopWith' does for appends). Left +-- as the poll default here because it is a latency optimisation, not a correctness +-- requirement. runShardedSubscriptionGroup :: - KirokuStore -> - SubscriptionName -> - ShardedWorkerOptions -> - (RecordedEvent -> IO ()) -> - IO () + KirokuStore -> + SubscriptionName -> + ShardedWorkerOptions -> + (RecordedEvent -> IO ()) -> + IO () runShardedSubscriptionGroup store subName opts handler = - runShardedSubscriptionGroupAck store subName opts $ \delivery -> do - handler (delivery ^. #event) - pure ShardAckOk + runShardedSubscriptionGroupAck store subName opts $ \delivery -> do + handler (delivery ^. #event) + pure ShardAckOk -{- | Acknowledgement-aware loop driver. Unlike the compatibility wrapper, the -handler decides whether each event advances, retries, or dead-letters. --} +-- | Acknowledgement-aware loop driver. Unlike the compatibility wrapper, the +-- handler decides whether each event advances, retries, or dead-letters. runShardedSubscriptionGroupAck :: - KirokuStore -> - SubscriptionName -> - ShardedWorkerOptions -> - ShardEventHandler -> - IO () + KirokuStore -> + SubscriptionName -> + ShardedWorkerOptions -> + ShardEventHandler -> + IO () runShardedSubscriptionGroupAck store subName opts handler = do - worker <- WorkerId <$> UUIDv4.nextRandom - let lease = - ShardLease - { subscriptionName = subName - , workerId = worker - , shardCount = opts ^. #shardCount - , leaseTtl = opts ^. #leaseTtl - } - ensured <- runStoreIO store (ensureShards lease) - case ensured of - Right () -> pure () - Left err -> reportShardError opts (ShardEnsureFailed (Text.pack (show err))) - readers <- newIORef Map.empty - loop lease readers `finally` cleanup lease readers + worker <- WorkerId <$> UUIDv4.nextRandom + let lease = + ShardLease + { subscriptionName = subName, + workerId = worker, + shardCount = opts ^. #shardCount, + leaseTtl = opts ^. #leaseTtl + } + ensured <- runStoreIO store (ensureShards lease) + case ensured of + Right () -> pure () + Left err -> reportShardError opts (ShardEnsureFailed (Text.pack (show err))) + readers <- newIORef Map.empty + loop lease readers `finally` cleanup lease readers where delayMicros = max 1 (round (realToFrac (opts ^. #renewInterval) * 1e6 :: Double)) loop lease readers = - forever $ do - _ <- reconcileShardsOnce store lease opts readers handler - threadDelay delayMicros + forever $ do + _ <- reconcileShardsOnce store lease opts readers handler + threadDelay delayMicros cleanup lease readers = do - current <- readIORef readers - for_ (Map.elems current) stopReader - _ <- runStoreIO store (relinquish lease (Map.keysSet current)) - pure () + current <- readIORef readers + for_ (Map.elems current) stopReader + _ <- runStoreIO store (relinquish lease (Map.keysSet current)) + pure () diff --git a/src/Keiro/Telemetry.hs b/src/Keiro/Telemetry.hs --- a/src/Keiro/Telemetry.hs +++ b/src/Keiro/Telemetry.hs @@ -1,31 +1,30 @@ -{- | Thin OpenTelemetry surface for the keiro library. - -This module is the single place keiro reaches for @hs-opentelemetry-api@ -and @hs-opentelemetry-semantic-conventions@. Callers configure a 'Tracer' -on the application side (typically via @hs-opentelemetry-sdk@'s -'OpenTelemetry.Trace.makeTracer'), then pass it through to keiro's -publisher / consumer / command surfaces. - -When no tracer is supplied, every helper degrades to a thin pass-through -(it calls the body and returns its value), so applications that do not -yet wire OpenTelemetry are unaffected. - -# Attribute keys - -keiro links @hs-opentelemetry-semantic-conventions@ @1.40.0.0@ (generated -from spec @v1.40@) directly. Every messaging.* / db.* typed 'AttributeKey' -the keiro audit cites (@docs/research/opentelemetry-semconv-audit.md@) is -imported from @OpenTelemetry.SemanticConventions@ and re-exported from this -module, so 'Keiro.Telemetry' remains the one-stop telemetry surface for the -library while every convention name is anchored to the spec-generated module -rather than a hand-typed string. - -Only the @keiro.*@ keys ('keiro_stream_name', 'keiro_retry_attempt', -'keiro_events_appended', 'keiro_replay_divergence') are defined locally: they -are bespoke to keiro and have no upstream equivalent. --} -module Keiro.Telemetry ( - -- * Span helpers +-- | Thin OpenTelemetry surface for the keiro library. +-- +-- This module is the single place keiro reaches for @hs-opentelemetry-api@ +-- and @hs-opentelemetry-semantic-conventions@. Callers configure a 'Tracer' +-- on the application side (typically via @hs-opentelemetry-sdk@'s +-- 'OpenTelemetry.Trace.makeTracer'), then pass it through to keiro's +-- publisher / consumer / command surfaces. +-- +-- When no tracer is supplied, every helper degrades to a thin pass-through +-- (it calls the body and returns its value), so applications that do not +-- yet wire OpenTelemetry are unaffected. +-- +-- # Attribute keys +-- +-- keiro links @hs-opentelemetry-semantic-conventions@ @1.40.0.0@ (generated +-- from spec @v1.40@) directly. Every messaging.* / db.* typed 'AttributeKey' +-- the keiro audit cites (@docs/research/opentelemetry-semconv-audit.md@) is +-- imported from @OpenTelemetry.SemanticConventions@ and re-exported from this +-- module, so 'Keiro.Telemetry' remains the one-stop telemetry surface for the +-- library while every convention name is anchored to the spec-generated module +-- rather than a hand-typed string. +-- +-- Only the @keiro.*@ keys ('keiro_stream_name', 'keiro_retry_attempt', +-- 'keiro_events_appended', 'keiro_replay_divergence') are defined locally: they +-- are bespoke to keiro and have no upstream equivalent. +module Keiro.Telemetry + ( -- * Span helpers Tracer, withProducerSpan, withConsumerSpan, @@ -155,22 +154,33 @@ -- * Kiroku observability bridge kirokuEventBridge, -) + ) where +import Keiro.Inbox.Kafka (KafkaInboundRecord) +import Keiro.Integration.Event + ( IntegrationEvent, + TraceContext (..), + headerTraceParent, + headerTraceState, + ) +import Keiro.Outbox.Kafka (KafkaProducerRecord) +import Keiro.Prelude +import Keiro.Workflow.Types (StepName (..), WorkflowId (..), WorkflowName (..)) +import Kiroku.Store.Observability (KirokuEvent (..)) import "base" Control.Exception (bracket) import "base" GHC.Stack (HasCallStack) import "bytestring" Data.ByteString qualified as ByteString import "hs-opentelemetry-api" OpenTelemetry.Attributes (emptyAttributes) import "hs-opentelemetry-api" OpenTelemetry.Attributes.Key (AttributeKey (..)) import "hs-opentelemetry-api" OpenTelemetry.Context (insertSpan, lookupSpan) -import "hs-opentelemetry-api" OpenTelemetry.Context.ThreadLocal ( - attachContext, +import "hs-opentelemetry-api" OpenTelemetry.Context.ThreadLocal + ( attachContext, detachContext, getContext, - ) -import "hs-opentelemetry-api" OpenTelemetry.Metric.Core ( - Counter, + ) +import "hs-opentelemetry-api" OpenTelemetry.Metric.Core + ( Counter, Gauge, Histogram, Meter, @@ -181,9 +191,9 @@ meterCreateCounterInt64, meterCreateGaugeInt64, meterCreateHistogram, - ) -import "hs-opentelemetry-api" OpenTelemetry.Trace.Core ( - InstrumentationLibrary (..), + ) +import "hs-opentelemetry-api" OpenTelemetry.Trace.Core + ( InstrumentationLibrary (..), Span, SpanArguments (..), SpanKind (..), @@ -192,9 +202,13 @@ defaultSpanArguments, inSpan', wrapSpanContext, - ) -import "hs-opentelemetry-semantic-conventions" OpenTelemetry.SemanticConventions ( - db_collection_name, + ) +import "hs-opentelemetry-propagator-w3c" OpenTelemetry.Propagator.W3CTraceContext + ( decodeSpanContext, + encodeSpanContext, + ) +import "hs-opentelemetry-semantic-conventions" OpenTelemetry.SemanticConventions + ( db_collection_name, db_namespace, db_operation_name, db_system_name, @@ -208,42 +222,24 @@ messaging_operation_name, messaging_operation_type, messaging_system, - ) + ) import "text" Data.Text qualified as Text import "text" Data.Text.Encoding qualified as TE import "unliftio-core" Control.Monad.IO.Unlift (MonadUnliftIO, withRunInIO) -import Keiro.Inbox.Kafka (KafkaInboundRecord) -import Keiro.Integration.Event ( - IntegrationEvent, - TraceContext (..), - headerTraceParent, - headerTraceState, - ) -import Keiro.Outbox.Kafka (KafkaProducerRecord) -import Keiro.Prelude -import Keiro.Workflow.Types (StepName (..), WorkflowId (..), WorkflowName (..)) -import Kiroku.Store.Observability (KirokuEvent (..)) - -import "hs-opentelemetry-propagator-w3c" OpenTelemetry.Propagator.W3CTraceContext ( - decodeSpanContext, - encodeSpanContext, - ) - -- --------------------------------------------------------------------------- -- Bespoke keiro AttributeKeys -- --------------------------------------------------------------------------- -{- $semconv_keys -The messaging.* / db.* 'AttributeKey's re-exported here are imported -directly from 'OpenTelemetry.SemanticConventions' -(@hs-opentelemetry-semantic-conventions@ @1.40.0.0@). They are surfaced -from this module so 'Keiro.Telemetry' stays the single telemetry import -for the library; their definitions live upstream. - -The @keiro_*@ keys below are bespoke to keiro and have no upstream -equivalent, so they are defined locally. --} +-- $semconv_keys +-- The messaging.* / db.* 'AttributeKey's re-exported here are imported +-- directly from 'OpenTelemetry.SemanticConventions' +-- (@hs-opentelemetry-semantic-conventions@ @1.40.0.0@). They are surfaced +-- from this module so 'Keiro.Telemetry' stays the single telemetry import +-- for the library; their definitions live upstream. +-- +-- The @keiro_*@ keys below are bespoke to keiro and have no upstream +-- equivalent, so they are defined locally. keiro_stream_name :: AttributeKey Text keiro_stream_name = AttributeKey "keiro.stream.name" @@ -270,246 +266,238 @@ -- Span helpers -- --------------------------------------------------------------------------- -{- | Run @body@ inside a @Producer@-kind span named @"send " <> destination@ -populated with the messaging attributes prescribed by -@docs/research/opentelemetry-semconv-audit.md@ for the outbox publish -site. - -When the supplied 'Tracer' is 'Nothing', the body runs unwrapped and the -helper is a no-op pass-through. This keeps the cost of the helper at -"one 'Maybe' branch" for applications that have not yet configured a -tracer. - -The body receives the producer 'Span' so it can record a publish failure -via 'recordPublishError'. --} +-- | Run @body@ inside a @Producer@-kind span named @"send " <> destination@ +-- populated with the messaging attributes prescribed by +-- @docs/research/opentelemetry-semconv-audit.md@ for the outbox publish +-- site. +-- +-- When the supplied 'Tracer' is 'Nothing', the body runs unwrapped and the +-- helper is a no-op pass-through. This keeps the cost of the helper at +-- "one 'Maybe' branch" for applications that have not yet configured a +-- tracer. +-- +-- The body receives the producer 'Span' so it can record a publish failure +-- via 'recordPublishError'. withProducerSpan :: - (MonadUnliftIO m, HasCallStack) => - Maybe Tracer -> - IntegrationEvent -> - KafkaProducerRecord -> - (Maybe Span -> m a) -> - m a + (MonadUnliftIO m, HasCallStack) => + Maybe Tracer -> + IntegrationEvent -> + KafkaProducerRecord -> + (Maybe Span -> m a) -> + m a withProducerSpan Nothing _ _ body = body Nothing withProducerSpan (Just tracer) event record body = - inSpan' tracer name args $ \sp -> do - setProducerAttributes sp event record - body (Just sp) + inSpan' tracer name args $ \sp -> do + setProducerAttributes sp event record + body (Just sp) where name = "send " <> (event ^. #destination) - args = defaultSpanArguments{kind = Producer} - -{- | Run @body@ inside a @Consumer@-kind span named @"process " <> topic@. - -Like 'withProducerSpan', the helper is a pass-through under a 'Nothing' -tracer. The 'KafkaInboundRecord' is required so the helper can populate -@messaging.kafka.offset@ and @messaging.destination.partition.id@ -without the caller threading them separately. + args = defaultSpanArguments {kind = Producer} -The optional 'Text' is a consumer group name, recorded as -@messaging.consumer.group.name@ when present. The 'IntegrationEvent' is -attached when present (decode succeeded), so @messaging.message.id@ -is set; otherwise the helper records only the headers known from the -broker record. --} +-- | Run @body@ inside a @Consumer@-kind span named @"process " <> topic@. +-- +-- Like 'withProducerSpan', the helper is a pass-through under a 'Nothing' +-- tracer. The 'KafkaInboundRecord' is required so the helper can populate +-- @messaging.kafka.offset@ and @messaging.destination.partition.id@ +-- without the caller threading them separately. +-- +-- The optional 'Text' is a consumer group name, recorded as +-- @messaging.consumer.group.name@ when present. The 'IntegrationEvent' is +-- attached when present (decode succeeded), so @messaging.message.id@ +-- is set; otherwise the helper records only the headers known from the +-- broker record. withConsumerSpan :: - (MonadUnliftIO m, HasCallStack) => - Maybe Tracer -> - -- | consumer group name (optional) - Maybe Text -> - KafkaInboundRecord -> - -- | decoded envelope; 'Nothing' on a decode failure path - Maybe IntegrationEvent -> - (Maybe Span -> m a) -> - m a + (MonadUnliftIO m, HasCallStack) => + Maybe Tracer -> + -- | consumer group name (optional) + Maybe Text -> + KafkaInboundRecord -> + -- | decoded envelope; 'Nothing' on a decode failure path + Maybe IntegrationEvent -> + (Maybe Span -> m a) -> + m a withConsumerSpan Nothing _ _ _ body = body Nothing withConsumerSpan (Just tracer) consumerGroup record mEvent body = - withRemoteParent (record ^. #headers) $ - inSpan' tracer name args $ \sp -> do - setConsumerAttributes sp consumerGroup record mEvent - body (Just sp) + withRemoteParent (record ^. #headers) $ + inSpan' tracer name args $ \sp -> do + setConsumerAttributes sp consumerGroup record mEvent + body (Just sp) where name = "process " <> (record ^. #topic) - args = defaultSpanArguments{kind = Consumer} - -{- | Run @body@ with the OpenTelemetry context temporarily augmented by a -parent span extracted from the supplied header list via the W3C -TraceContext propagator. - -When no @traceparent@ header is present (or it cannot be parsed) the -body runs unwrapped, so the helper is safe to call unconditionally. + args = defaultSpanArguments {kind = Consumer} -This is the bridge that makes a 'Consumer'-kind span open in this -process a *child* of the 'Producer'-kind span that emitted the message -in the upstream process, joining the two traces by trace id. --} +-- | Run @body@ with the OpenTelemetry context temporarily augmented by a +-- parent span extracted from the supplied header list via the W3C +-- TraceContext propagator. +-- +-- When no @traceparent@ header is present (or it cannot be parsed) the +-- body runs unwrapped, so the helper is safe to call unconditionally. +-- +-- This is the bridge that makes a 'Consumer'-kind span open in this +-- process a *child* of the 'Producer'-kind span that emitted the message +-- in the upstream process, joining the two traces by trace id. withRemoteParent :: - (MonadUnliftIO m) => [(Text, Text)] -> m a -> m a + (MonadUnliftIO m) => [(Text, Text)] -> m a -> m a withRemoteParent hs body = - case parentSpanContext hs of - Nothing -> body - Just spanCtx -> withRunInIO $ \runInIO -> do - ctx <- getContext - let newCtx = insertSpan (wrapSpanContext spanCtx) ctx - bracket - (attachContext newCtx) - detachContext - (const (runInIO body)) + case parentSpanContext hs of + Nothing -> body + Just spanCtx -> withRunInIO $ \runInIO -> do + ctx <- getContext + let newCtx = insertSpan (wrapSpanContext spanCtx) ctx + bracket + (attachContext newCtx) + detachContext + (const (runInIO body)) where parentSpanContext hsList = - let tp = fmap TE.encodeUtf8 (Prelude.lookup headerTraceParent hsList) - ts = fmap TE.encodeUtf8 (Prelude.lookup headerTraceState hsList) - in decodeSpanContext tp ts + let tp = fmap TE.encodeUtf8 (Prelude.lookup headerTraceParent hsList) + ts = fmap TE.encodeUtf8 (Prelude.lookup headerTraceState hsList) + in decodeSpanContext tp ts -{- | Open an @Internal@ span around a command run, named after the resolved -stream identifier. Attributes capture the stream name and (when the -caller supplies it) the retry attempt number. The number of events -appended is attached after a successful append by the caller via -'addAttribute span keiro_events_appended n'. --} +-- | Open an @Internal@ span around a command run, named after the resolved +-- stream identifier. Attributes capture the stream name and (when the +-- caller supplies it) the retry attempt number. The number of events +-- appended is attached after a successful append by the caller via +-- 'addAttribute span keiro_events_appended n'. withCommandSpan :: - (MonadUnliftIO m, HasCallStack) => - Maybe Tracer -> - -- | resolved stream name - Text -> - -- | retry attempt (1-based); 'Nothing' to omit - Maybe Int64 -> - (Maybe Span -> m a) -> - m a + (MonadUnliftIO m, HasCallStack) => + Maybe Tracer -> + -- | resolved stream name + Text -> + -- | retry attempt (1-based); 'Nothing' to omit + Maybe Int64 -> + (Maybe Span -> m a) -> + m a withCommandSpan Nothing _ _ body = body Nothing withCommandSpan (Just tracer) streamName retryAttempt body = - inSpan' tracer streamName args $ \sp -> do - addAttribute sp (unkey keiro_stream_name) streamName - case retryAttempt of - Nothing -> pure () - Just n -> addAttribute sp (unkey keiro_retry_attempt) n - body (Just sp) + inSpan' tracer streamName args $ \sp -> do + addAttribute sp (unkey keiro_stream_name) streamName + case retryAttempt of + Nothing -> pure () + Just n -> addAttribute sp (unkey keiro_retry_attempt) n + body (Just sp) where - args = defaultSpanArguments{kind = Internal} + args = defaultSpanArguments {kind = Internal} -{- | Open an @Internal@ span around a workflow run (or a single step/resume when -a 'StepName' is supplied), named @"workflow " <> name@. Attributes carry the -bespoke @keiro.workflow.name@, @keiro.workflow.id@, and — when present — -@keiro.workflow.step@ keys. Like 'withCommandSpan', a 'Nothing' tracer makes the -helper a pass-through, so it is safe to call unconditionally. --} +-- | Open an @Internal@ span around a workflow run (or a single step/resume when +-- a 'StepName' is supplied), named @"workflow " <> name@. Attributes carry the +-- bespoke @keiro.workflow.name@, @keiro.workflow.id@, and — when present — +-- @keiro.workflow.step@ keys. Like 'withCommandSpan', a 'Nothing' tracer makes the +-- helper a pass-through, so it is safe to call unconditionally. withWorkflowSpan :: - (MonadUnliftIO m, HasCallStack) => - Maybe Tracer -> - WorkflowName -> - WorkflowId -> - Maybe StepName -> - (Maybe Span -> m a) -> - m a + (MonadUnliftIO m, HasCallStack) => + Maybe Tracer -> + WorkflowName -> + WorkflowId -> + Maybe StepName -> + (Maybe Span -> m a) -> + m a withWorkflowSpan Nothing _ _ _ body = body Nothing withWorkflowSpan (Just tracer) name wid mStep body = - inSpan' tracer spanName args $ \sp -> do - addAttribute sp (unkey keiro_workflow_name) (unWorkflowName name) - addAttribute sp (unkey keiro_workflow_id) (unWorkflowId wid) - case mStep of - Nothing -> pure () - Just s -> addAttribute sp (unkey keiro_workflow_step) (unStepName s) - body (Just sp) + inSpan' tracer spanName args $ \sp -> do + addAttribute sp (unkey keiro_workflow_name) (unWorkflowName name) + addAttribute sp (unkey keiro_workflow_id) (unWorkflowId wid) + case mStep of + Nothing -> pure () + Just s -> addAttribute sp (unkey keiro_workflow_step) (unStepName s) + body (Just sp) where spanName = "workflow " <> unWorkflowName name - args = defaultSpanArguments{kind = Internal} + args = defaultSpanArguments {kind = Internal} -- --------------------------------------------------------------------------- -- W3C TraceContext bridge -- --------------------------------------------------------------------------- -{- | Read the current thread-local span context and format it as a -'TraceContext'. Returns 'Nothing' when no span is active on the current -thread. - -The application is expected to have already configured the W3C -propagator on its 'TracerProvider' (so the propagator is responsible for -on-the-wire framing); this helper is the keiro-side bridge between the -in-memory span and the keiro 'TraceContext' record stored on -'IntegrationEvent' envelopes and outbox rows. --} +-- | Read the current thread-local span context and format it as a +-- 'TraceContext'. Returns 'Nothing' when no span is active on the current +-- thread. +-- +-- The application is expected to have already configured the W3C +-- propagator on its 'TracerProvider' (so the propagator is responsible for +-- on-the-wire framing); this helper is the keiro-side bridge between the +-- in-memory span and the keiro 'TraceContext' record stored on +-- 'IntegrationEvent' envelopes and outbox rows. traceContextFromCurrentSpan :: (MonadIO m) => m (Maybe TraceContext) traceContextFromCurrentSpan = do - ctx <- getContext - case lookupSpan ctx of - Nothing -> pure Nothing - Just sp -> do - (traceparentBytes, tracestateBytes) <- liftIO (encodeSpanContext sp) - let traceparent = TE.decodeUtf8 traceparentBytes - tracestate - | ByteString.null tracestateBytes = Nothing - | otherwise = Just (TE.decodeUtf8 tracestateBytes) - pure (Just (TraceContext traceparent tracestate)) + ctx <- getContext + case lookupSpan ctx of + Nothing -> pure Nothing + Just sp -> do + (traceparentBytes, tracestateBytes) <- liftIO (encodeSpanContext sp) + let traceparent = TE.decodeUtf8 traceparentBytes + tracestate + | ByteString.null tracestateBytes = Nothing + | otherwise = Just (TE.decodeUtf8 tracestateBytes) + pure (Just (TraceContext traceparent tracestate)) -{- | Lift a 'TraceContext' out of a flat @[(Text, Text)]@ header list. This -is the mirror image of 'integrationHeaders': it does not validate the -@traceparent@ format (the W3C propagator's parser does that at consume -time); it merely converts the on-the-wire pair of headers to the keiro -envelope record. --} +-- | Lift a 'TraceContext' out of a flat @[(Text, Text)]@ header list. This +-- is the mirror image of 'integrationHeaders': it does not validate the +-- @traceparent@ format (the W3C propagator's parser does that at consume +-- time); it merely converts the on-the-wire pair of headers to the keiro +-- envelope record. traceContextFromHeaders :: [(Text, Text)] -> Maybe TraceContext traceContextFromHeaders hs = case Prelude.lookup headerTraceParent hs of - Nothing -> Nothing - Just tp -> Just (TraceContext tp (Prelude.lookup headerTraceState hs)) - -{- | Append the W3C @traceparent@ / @tracestate@ headers for the current -thread-local span to the supplied header list. When no span is active -on the current thread, the input list is returned unchanged. + Nothing -> Nothing + Just tp -> Just (TraceContext tp (Prelude.lookup headerTraceState hs)) -Used by adapters that build a flat header list from their own envelope -(e.g. the outbox publisher) so the headers carry the active span -context even if the caller did not capture a 'TraceContext' onto the -event explicitly. --} +-- | Append the W3C @traceparent@ / @tracestate@ headers for the current +-- thread-local span to the supplied header list. When no span is active +-- on the current thread, the input list is returned unchanged. +-- +-- Used by adapters that build a flat header list from their own envelope +-- (e.g. the outbox publisher) so the headers carry the active span +-- context even if the caller did not capture a 'TraceContext' onto the +-- event explicitly. injectTraceContext :: (MonadIO m) => [(Text, Text)] -> m [(Text, Text)] injectTraceContext hs = do - mctx <- traceContextFromCurrentSpan - pure $ case mctx of - Nothing -> hs - Just tc -> - hs - ++ [(headerTraceParent, tc ^. #traceparent)] - ++ maybe [] (\ts -> [(headerTraceState, ts)]) (tc ^. #tracestate) + mctx <- traceContextFromCurrentSpan + pure $ case mctx of + Nothing -> hs + Just tc -> + hs + ++ [(headerTraceParent, tc ^. #traceparent)] + ++ maybe [] (\ts -> [(headerTraceState, ts)]) (tc ^. #tracestate) -- --------------------------------------------------------------------------- -- Internal helpers -- --------------------------------------------------------------------------- setProducerAttributes :: - (MonadIO m) => Span -> IntegrationEvent -> KafkaProducerRecord -> m () + (MonadIO m) => Span -> IntegrationEvent -> KafkaProducerRecord -> m () setProducerAttributes sp event _record = do - addAttribute sp (unkey messaging_system) ("kafka" :: Text) - addAttribute sp (unkey messaging_operation_type) ("publish" :: Text) - addAttribute sp (unkey messaging_operation_name) ("send" :: Text) - addAttribute sp (unkey messaging_destination_name) (event ^. #destination) - addAttribute sp (unkey messaging_message_id) (event ^. #messageId) - case event ^. #key of - Nothing -> pure () - Just k -> addAttribute sp (unkey messaging_kafka_message_key) k + addAttribute sp (unkey messaging_system) ("kafka" :: Text) + addAttribute sp (unkey messaging_operation_type) ("publish" :: Text) + addAttribute sp (unkey messaging_operation_name) ("send" :: Text) + addAttribute sp (unkey messaging_destination_name) (event ^. #destination) + addAttribute sp (unkey messaging_message_id) (event ^. #messageId) + case event ^. #key of + Nothing -> pure () + Just k -> addAttribute sp (unkey messaging_kafka_message_key) k setConsumerAttributes :: - (MonadIO m) => - Span -> - Maybe Text -> - KafkaInboundRecord -> - Maybe IntegrationEvent -> - m () + (MonadIO m) => + Span -> + Maybe Text -> + KafkaInboundRecord -> + Maybe IntegrationEvent -> + m () setConsumerAttributes sp consumerGroup record mEvent = do - addAttribute sp (unkey messaging_system) ("kafka" :: Text) - addAttribute sp (unkey messaging_operation_type) ("process" :: Text) - addAttribute sp (unkey messaging_operation_name) ("process" :: Text) - addAttribute sp (unkey messaging_destination_name) (record ^. #topic) - addAttribute sp (unkey messaging_destination_partition_id) (showText (record ^. #partition)) - addAttribute sp (unkey messaging_kafka_offset) (record ^. #offset) - case record ^. #key of - Nothing -> pure () - Just k -> addAttribute sp (unkey messaging_kafka_message_key) k - case consumerGroup of - Nothing -> pure () - Just g -> addAttribute sp (unkey messaging_consumer_group_name) g - case mEvent of - Nothing -> pure () - Just event -> addAttribute sp (unkey messaging_message_id) (event ^. #messageId) + addAttribute sp (unkey messaging_system) ("kafka" :: Text) + addAttribute sp (unkey messaging_operation_type) ("process" :: Text) + addAttribute sp (unkey messaging_operation_name) ("process" :: Text) + addAttribute sp (unkey messaging_destination_name) (record ^. #topic) + addAttribute sp (unkey messaging_destination_partition_id) (showText (record ^. #partition)) + addAttribute sp (unkey messaging_kafka_offset) (record ^. #offset) + case record ^. #key of + Nothing -> pure () + Just k -> addAttribute sp (unkey messaging_kafka_message_key) k + case consumerGroup of + Nothing -> pure () + Just g -> addAttribute sp (unkey messaging_consumer_group_name) g + case mEvent of + Nothing -> pure () + Just event -> addAttribute sp (unkey messaging_message_id) (event ^. #messageId) showText :: (Show a) => a -> Text showText = Text.pack . show @@ -518,394 +506,469 @@ -- Metrics surface -- --------------------------------------------------------------------------- -{- $metrics -Alongside the span helpers above, 'Keiro.Telemetry' exposes the library's -metrics surface: a 'KeiroMetrics' record holding every instrument keiro -records (built once from a 'Meter' by 'newKeiroMetrics'), and one -@record*@ helper per instrument that takes a @'Maybe' 'KeiroMetrics'@ and -no-ops on 'Nothing'. This mirrors the @'Maybe' 'Tracer'@ opt-in the span -helpers use: an application that never configures a 'MeterProvider' pays -only one 'Maybe' branch per recording site. The per-instrument name, unit, -kind, and description are catalogued in -@docs/research/opentelemetry-semconv-audit.md@. --} +-- $metrics +-- Alongside the span helpers above, 'Keiro.Telemetry' exposes the library's +-- metrics surface: a 'KeiroMetrics' record holding every instrument keiro +-- records (built once from a 'Meter' by 'newKeiroMetrics'), and one +-- @record*@ helper per instrument that takes a @'Maybe' 'KeiroMetrics'@ and +-- no-ops on 'Nothing'. This mirrors the @'Maybe' 'Tracer'@ opt-in the span +-- helpers use: an application that never configures a 'MeterProvider' pays +-- only one 'Maybe' branch per recording site. The per-instrument name, unit, +-- kind, and description are catalogued in +-- @docs/research/opentelemetry-semconv-audit.md@. -{- | The instrumentation scope keiro tags all its metric instruments with. -Mirrors the @"keiro"@ scope name the span helpers use on the application's -'Tracer'. --} +-- | The instrumentation scope keiro tags all its metric instruments with. +-- Mirrors the @"keiro"@ scope name the span helpers use on the application's +-- 'Tracer'. keiroInstrumentationLibrary :: InstrumentationLibrary keiroInstrumentationLibrary = - InstrumentationLibrary - { libraryName = "keiro" - , libraryVersion = "" - , librarySchemaUrl = "" - , libraryAttributes = emptyAttributes - } + InstrumentationLibrary + { libraryName = "keiro", + libraryVersion = "", + librarySchemaUrl = "", + libraryAttributes = emptyAttributes + } keiroOutboxBacklogName :: Text keiroOutboxBacklogName = "keiro.outbox.backlog" + keiroOutboxPublishedName :: Text keiroOutboxPublishedName = "keiro.outbox.published" + keiroOutboxRetriedName :: Text keiroOutboxRetriedName = "keiro.outbox.retried" + keiroOutboxDeadletteredName :: Text keiroOutboxDeadletteredName = "keiro.outbox.deadlettered" + keiroOutboxReclaimedName :: Text keiroOutboxReclaimedName = "keiro.outbox.reclaimed" + keiroInboxProcessedName :: Text keiroInboxProcessedName = "keiro.inbox.processed" + keiroInboxDuplicatesName :: Text keiroInboxDuplicatesName = "keiro.inbox.duplicates" + keiroInboxFailedName :: Text keiroInboxFailedName = "keiro.inbox.failed" + keiroInboxPoisonedName :: Text keiroInboxPoisonedName = "keiro.inbox.poisoned" + keiroInboxBacklogName :: Text keiroInboxBacklogName = "keiro.inbox.backlog" + keiroTimerBacklogName :: Text keiroTimerBacklogName = "keiro.timer.backlog" + keiroTimerFireLagName :: Text keiroTimerFireLagName = "keiro.timer.fire.lag" + keiroTimerAttemptsName :: Text keiroTimerAttemptsName = "keiro.timer.attempts" + keiroTimerStuckName :: Text keiroTimerStuckName = "keiro.timer.stuck" + keiroTimerRequeuedName :: Text keiroTimerRequeuedName = "keiro.timer.requeued" + keiroProjectionLagName :: Text keiroProjectionLagName = "keiro.projection.lag" + keiroProjectionWaitTimeoutsName :: Text keiroProjectionWaitTimeoutsName = "keiro.projection.wait.timeouts" + keiroCommandConflictsName :: Text keiroCommandConflictsName = "keiro.command.conflicts" + keiroCommandRetriesName :: Text keiroCommandRetriesName = "keiro.command.retries" + keiroCommandDuplicatesName :: Text keiroCommandDuplicatesName = "keiro.command.duplicates" + keiroSnapshotDecodeFailuresName :: Text keiroSnapshotDecodeFailuresName = "keiro.snapshot.decode.failures" + keiroSnapshotEncodeFailuresName :: Text keiroSnapshotEncodeFailuresName = "keiro.snapshot.encode.failures" + keiroSnapshotReadHitsName :: Text keiroSnapshotReadHitsName = "keiro.snapshot.read.hits" + keiroSnapshotReadMissesName :: Text keiroSnapshotReadMissesName = "keiro.snapshot.read.misses" + keiroSnapshotWriteFailuresName :: Text keiroSnapshotWriteFailuresName = "keiro.snapshot.write.failures" + keiroSnapshotApplyDivergenceName :: Text keiroSnapshotApplyDivergenceName = "keiro.snapshot.apply.divergence" + keiroSnapshotSeedDivergenceName :: Text keiroSnapshotSeedDivergenceName = "keiro.snapshot.seed.divergence" + keiroDispatchFailedName :: Text keiroDispatchFailedName = "keiro.dispatch.failed" + keiroDispatchDeadletteredName :: Text keiroDispatchDeadletteredName = "keiro.dispatch.deadlettered" + keiroSubscriptionDeadletteredName :: Text keiroSubscriptionDeadletteredName = "keiro.subscription.deadlettered" + keiroDispatchDuplicatesName :: Text keiroDispatchDuplicatesName = "keiro.dispatch.duplicates" + keiroDispatchPoisonName :: Text keiroDispatchPoisonName = "keiro.dispatch.poison" + keiroWorkflowStepsExecutedName :: Text keiroWorkflowStepsExecutedName = "keiro.workflow.steps.executed" + keiroWorkflowStepsReplayedName :: Text keiroWorkflowStepsReplayedName = "keiro.workflow.steps.replayed" + keiroWorkflowResumedName :: Text keiroWorkflowResumedName = "keiro.workflow.resumed" + keiroWorkflowFailedName :: Text keiroWorkflowFailedName = "keiro.workflow.failed" + keiroWorkflowResumeErrorsName :: Text keiroWorkflowResumeErrorsName = "keiro.workflow.resume.errors" + keiroWorkflowLeaseSkippedName :: Text keiroWorkflowLeaseSkippedName = "keiro.workflow.lease.skipped" + keiroWorkflowJournalLengthName :: Text keiroWorkflowJournalLengthName = "keiro.workflow.journal.length" + keiroWorkflowAwakeablesPendingName :: Text keiroWorkflowAwakeablesPendingName = "keiro.workflow.awakeables.pending" + keiroWorkflowActiveName :: Text keiroWorkflowActiveName = "keiro.workflow.active" -{- | All metric instruments the keiro library records, built once from a -'Meter' by 'newKeiroMetrics'. Workers accept a @'Maybe' 'KeiroMetrics'@ and -treat 'Nothing' as "record nothing"; the per-instrument recording helpers in -this module take @'Maybe' 'KeiroMetrics'@ so call sites stay one-liners. - -Instrument kinds follow the keiro metrics policy: backlog and lag are -synchronous gauges recorded by each worker per poll pass; tallies are -monotonic counters; distributions are histograms. See -@docs/research/opentelemetry-semconv-audit.md@ for the per-instrument -name / unit / kind / description catalogue. --} +-- | All metric instruments the keiro library records, built once from a +-- 'Meter' by 'newKeiroMetrics'. Workers accept a @'Maybe' 'KeiroMetrics'@ and +-- treat 'Nothing' as "record nothing"; the per-instrument recording helpers in +-- this module take @'Maybe' 'KeiroMetrics'@ so call sites stay one-liners. +-- +-- Instrument kinds follow the keiro metrics policy: backlog and lag are +-- synchronous gauges recorded by each worker per poll pass; tallies are +-- monotonic counters; distributions are histograms. See +-- @docs/research/opentelemetry-semconv-audit.md@ for the per-instrument +-- name / unit / kind / description catalogue. data KeiroMetrics = KeiroMetrics - { outboxBacklog :: Gauge Int64 - , outboxPublished :: Counter Int64 - , outboxRetried :: Counter Int64 - , outboxDeadlettered :: Counter Int64 - , outboxReclaimed :: Counter Int64 - , inboxProcessed :: Counter Int64 - , inboxDuplicates :: Counter Int64 - , inboxFailed :: Counter Int64 - , inboxPoisoned :: Counter Int64 - , inboxBacklog :: Gauge Int64 - , timerBacklog :: Gauge Int64 - , timerFireLag :: Histogram - , timerAttempts :: Histogram - , timerStuck :: Gauge Int64 - , timerRequeued :: Counter Int64 - , projectionLag :: Gauge Int64 - , projectionWaitTimeouts :: Counter Int64 - , commandConflicts :: Counter Int64 - , commandRetries :: Counter Int64 - , commandDuplicates :: Counter Int64 - , snapshotDecodeFailures :: Counter Int64 - , snapshotEncodeFailures :: Counter Int64 - , snapshotReadHits :: Counter Int64 - , snapshotReadMisses :: Counter Int64 - , snapshotWriteFailures :: Counter Int64 - , snapshotApplyDivergence :: Counter Int64 - , snapshotSeedDivergence :: Counter Int64 - , dispatchFailed :: Counter Int64 - , dispatchDeadlettered :: Counter Int64 - , subscriptionDeadlettered :: Counter Int64 - , dispatchDuplicates :: Counter Int64 - , dispatchPoison :: Counter Int64 - , workflowStepsExecuted :: Counter Int64 - , workflowStepsReplayed :: Counter Int64 - , workflowResumed :: Counter Int64 - , workflowFailed :: Counter Int64 - , workflowResumeErrors :: Counter Int64 - , workflowLeaseSkipped :: Counter Int64 - , workflowActive :: Gauge Int64 - , workflowJournalLength :: Histogram - , workflowAwakeablesPending :: Gauge Int64 - } + { outboxBacklog :: Gauge Int64, + outboxPublished :: Counter Int64, + outboxRetried :: Counter Int64, + outboxDeadlettered :: Counter Int64, + outboxReclaimed :: Counter Int64, + inboxProcessed :: Counter Int64, + inboxDuplicates :: Counter Int64, + inboxFailed :: Counter Int64, + inboxPoisoned :: Counter Int64, + inboxBacklog :: Gauge Int64, + timerBacklog :: Gauge Int64, + timerFireLag :: Histogram, + timerAttempts :: Histogram, + timerStuck :: Gauge Int64, + timerRequeued :: Counter Int64, + projectionLag :: Gauge Int64, + projectionWaitTimeouts :: Counter Int64, + commandConflicts :: Counter Int64, + commandRetries :: Counter Int64, + commandDuplicates :: Counter Int64, + snapshotDecodeFailures :: Counter Int64, + snapshotEncodeFailures :: Counter Int64, + snapshotReadHits :: Counter Int64, + snapshotReadMisses :: Counter Int64, + snapshotWriteFailures :: Counter Int64, + snapshotApplyDivergence :: Counter Int64, + snapshotSeedDivergence :: Counter Int64, + dispatchFailed :: Counter Int64, + dispatchDeadlettered :: Counter Int64, + subscriptionDeadlettered :: Counter Int64, + dispatchDuplicates :: Counter Int64, + dispatchPoison :: Counter Int64, + workflowStepsExecuted :: Counter Int64, + workflowStepsReplayed :: Counter Int64, + workflowResumed :: Counter Int64, + workflowFailed :: Counter Int64, + workflowResumeErrors :: Counter Int64, + workflowLeaseSkipped :: Counter Int64, + workflowActive :: Gauge Int64, + workflowJournalLength :: Histogram, + workflowAwakeablesPending :: Gauge Int64 + } -{- | Construct every keiro metric instrument from a 'Meter'. Call this once at -application start after building an SDK 'OpenTelemetry.Metric.Core.MeterProvider' -and obtaining a 'Meter' (e.g. @getMeter mp keiroInstrumentationLibrary@), then -thread the resulting 'KeiroMetrics' into workers as @'Just' metrics@. Under a -no-op meter every instrument is itself a no-op, so this is safe to call -unconditionally. --} +-- | Construct every keiro metric instrument from a 'Meter'. Call this once at +-- application start after building an SDK 'OpenTelemetry.Metric.Core.MeterProvider' +-- and obtaining a 'Meter' (e.g. @getMeter mp keiroInstrumentationLibrary@), then +-- thread the resulting 'KeiroMetrics' into workers as @'Just' metrics@. Under a +-- no-op meter every instrument is itself a no-op, so this is safe to call +-- unconditionally. newKeiroMetrics :: (MonadIO m) => Meter -> m KeiroMetrics newKeiroMetrics meter = liftIO $ do - outboxBacklog' <- gaugeI64 keiroOutboxBacklogName "{event}" "Outbox rows awaiting publish." - outboxPublished' <- counterI64 keiroOutboxPublishedName "{event}" "Outbox events successfully published." - outboxRetried' <- counterI64 keiroOutboxRetriedName "{event}" "Outbox publish attempts that failed and will retry." - outboxDeadlettered' <- counterI64 keiroOutboxDeadletteredName "{event}" "Outbox events parked after exhausting retries." - outboxReclaimed' <- counterI64 keiroOutboxReclaimedName "{event}" "Outbox rows reclaimed from a crashed or stalled publisher." - inboxProcessed' <- counterI64 keiroInboxProcessedName "{message}" "Inbox messages processed successfully." - inboxDuplicates' <- counterI64 keiroInboxDuplicatesName "{message}" "Inbox messages skipped as duplicates." - inboxFailed' <- counterI64 keiroInboxFailedName "{message}" "Inbox messages whose handler failed." - inboxPoisoned' <- counterI64 keiroInboxPoisonedName "{message}" "Inbox messages dead-lettered after exhausting handler attempts." - inboxBacklog' <- gaugeI64 keiroInboxBacklogName "{message}" "Inbox messages awaiting processing." - timerBacklog' <- gaugeI64 keiroTimerBacklogName "{timer}" "Due timers awaiting firing." - timerFireLag' <- histogram keiroTimerFireLagName "ms" "Delay between a timer's scheduled time and when it fired." - timerAttempts' <- histogram keiroTimerAttemptsName "{attempt}" "Number of attempts a timer took to fire." - timerStuck' <- gaugeI64 keiroTimerStuckName "{timer}" "Timers stuck in the Firing state past threshold." - timerRequeued' <- counterI64 keiroTimerRequeuedName "{timer}" "Timers moved from firing back to scheduled after a stale claim." - projectionLag' <- gaugeI64 keiroProjectionLagName "{event}" "Events between the log head and a projection's checkpoint." - projectionWaitTimeouts' <- counterI64 keiroProjectionWaitTimeoutsName "{timeout}" "Position-wait calls that timed out before the projection caught up." - commandConflicts' <- counterI64 keiroCommandConflictsName "{conflict}" "Optimistic-concurrency conflicts observed by command runners." - commandRetries' <- counterI64 keiroCommandRetriesName "{retry}" "Command retry attempts started after an optimistic-concurrency conflict." - commandDuplicates' <- counterI64 keiroCommandDuplicatesName "{event}" "Command appends rejected as duplicate deterministic event ids." - snapshotDecodeFailures' <- counterI64 keiroSnapshotDecodeFailuresName "{failure}" "Snapshot rows whose bytes failed to decode; hydration fell back to full replay." - snapshotEncodeFailures' <- counterI64 keiroSnapshotEncodeFailuresName "{failure}" "Post-commit snapshot encodes that failed and were swallowed." - snapshotReadHits' <- counterI64 keiroSnapshotReadHitsName "{read}" "Snapshot lookups that yielded a usable hydration seed." - snapshotReadMisses' <- counterI64 keiroSnapshotReadMissesName "{read}" "Snapshot lookups that fell back to full replay." - snapshotWriteFailures' <- counterI64 keiroSnapshotWriteFailuresName "{failure}" "Post-commit snapshot writes that failed and were swallowed." - snapshotApplyDivergence' <- counterI64 keiroSnapshotApplyDivergenceName "{failure}" "Just-appended event batches that failed to replay from the pre-command state; the stream is poisoned and its next hydration will fail." - snapshotSeedDivergence' <- counterI64 keiroSnapshotSeedDivergenceName "{failure}" "Sampled snapshot seeds whose encoded state disagreed with a full replay through the seed version." - dispatchFailed' <- counterI64 keiroDispatchFailedName "{command}" "Process-manager/router dispatch commands that failed." - dispatchDeadlettered' <- counterI64 keiroDispatchDeadletteredName "{command}" "Rejected process-manager/router dispatch commands handled by dead-letter or skip policy." - subscriptionDeadlettered' <- counterI64 keiroSubscriptionDeadletteredName "{event}" "Kiroku source events dead-lettered by an explicit disposition or retry exhaustion." - dispatchDuplicates' <- counterI64 keiroDispatchDuplicatesName "{command}" "Process-manager/router dispatch commands skipped as duplicate deterministic event ids." - dispatchPoison' <- counterI64 keiroDispatchPoisonName "{message}" "Process-manager/router worker messages classified as poison." - workflowStepsExecuted' <- counterI64 keiroWorkflowStepsExecutedName "{step}" "Workflow steps that ran their action (a journal miss)." - workflowStepsReplayed' <- counterI64 keiroWorkflowStepsReplayedName "{step}" "Workflow steps short-circuited to a recorded result (a journal hit)." - workflowResumed' <- counterI64 keiroWorkflowResumedName "{workflow}" "Workflow re-invocations performed by the resume worker." - workflowFailed' <- counterI64 keiroWorkflowFailedName "{workflow}" "Workflow instances marked terminally failed by the resume worker." - workflowResumeErrors' <- counterI64 keiroWorkflowResumeErrorsName "{error}" "Transient store errors observed by the workflow resume worker." - workflowLeaseSkipped' <- counterI64 keiroWorkflowLeaseSkippedName "{workflow}" "Workflow instances skipped because another worker owns their lease." - workflowActive' <- gaugeI64 keiroWorkflowActiveName "{workflow}" "Workflow runs currently in progress in this process." - workflowJournalLength' <- histogram keiroWorkflowJournalLengthName "{event}" "Journal event count of a workflow at completion." - workflowAwakeablesPending' <- gaugeI64 keiroWorkflowAwakeablesPendingName "{awakeable}" "Awakeables awaiting an external signal." - pure - KeiroMetrics - { outboxBacklog = outboxBacklog' - , outboxPublished = outboxPublished' - , outboxRetried = outboxRetried' - , outboxDeadlettered = outboxDeadlettered' - , outboxReclaimed = outboxReclaimed' - , inboxProcessed = inboxProcessed' - , inboxDuplicates = inboxDuplicates' - , inboxFailed = inboxFailed' - , inboxPoisoned = inboxPoisoned' - , inboxBacklog = inboxBacklog' - , timerBacklog = timerBacklog' - , timerFireLag = timerFireLag' - , timerAttempts = timerAttempts' - , timerStuck = timerStuck' - , timerRequeued = timerRequeued' - , projectionLag = projectionLag' - , projectionWaitTimeouts = projectionWaitTimeouts' - , commandConflicts = commandConflicts' - , commandRetries = commandRetries' - , commandDuplicates = commandDuplicates' - , snapshotDecodeFailures = snapshotDecodeFailures' - , snapshotEncodeFailures = snapshotEncodeFailures' - , snapshotReadHits = snapshotReadHits' - , snapshotReadMisses = snapshotReadMisses' - , snapshotWriteFailures = snapshotWriteFailures' - , snapshotApplyDivergence = snapshotApplyDivergence' - , snapshotSeedDivergence = snapshotSeedDivergence' - , dispatchFailed = dispatchFailed' - , dispatchDeadlettered = dispatchDeadlettered' - , subscriptionDeadlettered = subscriptionDeadlettered' - , dispatchDuplicates = dispatchDuplicates' - , dispatchPoison = dispatchPoison' - , workflowStepsExecuted = workflowStepsExecuted' - , workflowStepsReplayed = workflowStepsReplayed' - , workflowResumed = workflowResumed' - , workflowFailed = workflowFailed' - , workflowResumeErrors = workflowResumeErrors' - , workflowLeaseSkipped = workflowLeaseSkipped' - , workflowActive = workflowActive' - , workflowJournalLength = workflowJournalLength' - , workflowAwakeablesPending = workflowAwakeablesPending' - } + outboxBacklog' <- gaugeI64 keiroOutboxBacklogName "{event}" "Outbox rows awaiting publish." + outboxPublished' <- counterI64 keiroOutboxPublishedName "{event}" "Outbox events successfully published." + outboxRetried' <- counterI64 keiroOutboxRetriedName "{event}" "Outbox publish attempts that failed and will retry." + outboxDeadlettered' <- counterI64 keiroOutboxDeadletteredName "{event}" "Outbox events parked after exhausting retries." + outboxReclaimed' <- counterI64 keiroOutboxReclaimedName "{event}" "Outbox rows reclaimed from a crashed or stalled publisher." + inboxProcessed' <- counterI64 keiroInboxProcessedName "{message}" "Inbox messages processed successfully." + inboxDuplicates' <- counterI64 keiroInboxDuplicatesName "{message}" "Inbox messages skipped as duplicates." + inboxFailed' <- counterI64 keiroInboxFailedName "{message}" "Inbox messages whose handler failed." + inboxPoisoned' <- counterI64 keiroInboxPoisonedName "{message}" "Inbox messages dead-lettered after exhausting handler attempts." + inboxBacklog' <- gaugeI64 keiroInboxBacklogName "{message}" "Inbox messages awaiting processing." + timerBacklog' <- gaugeI64 keiroTimerBacklogName "{timer}" "Due timers awaiting firing." + timerFireLag' <- histogram keiroTimerFireLagName "ms" "Delay between a timer's scheduled time and when it fired." + timerAttempts' <- histogram keiroTimerAttemptsName "{attempt}" "Number of attempts a timer took to fire." + timerStuck' <- gaugeI64 keiroTimerStuckName "{timer}" "Timers stuck in the Firing state past threshold." + timerRequeued' <- counterI64 keiroTimerRequeuedName "{timer}" "Timers moved from firing back to scheduled after a stale claim." + projectionLag' <- gaugeI64 keiroProjectionLagName "{event}" "Events between the log head and a projection's checkpoint." + projectionWaitTimeouts' <- counterI64 keiroProjectionWaitTimeoutsName "{timeout}" "Position-wait calls that timed out before the projection caught up." + commandConflicts' <- counterI64 keiroCommandConflictsName "{conflict}" "Optimistic-concurrency conflicts observed by command runners." + commandRetries' <- counterI64 keiroCommandRetriesName "{retry}" "Command retry attempts started after an optimistic-concurrency conflict." + commandDuplicates' <- counterI64 keiroCommandDuplicatesName "{event}" "Command appends rejected as duplicate deterministic event ids." + snapshotDecodeFailures' <- counterI64 keiroSnapshotDecodeFailuresName "{failure}" "Snapshot rows whose bytes failed to decode; hydration fell back to full replay." + snapshotEncodeFailures' <- counterI64 keiroSnapshotEncodeFailuresName "{failure}" "Post-commit snapshot encodes that failed and were swallowed." + snapshotReadHits' <- counterI64 keiroSnapshotReadHitsName "{read}" "Snapshot lookups that yielded a usable hydration seed." + snapshotReadMisses' <- counterI64 keiroSnapshotReadMissesName "{read}" "Snapshot lookups that fell back to full replay." + snapshotWriteFailures' <- counterI64 keiroSnapshotWriteFailuresName "{failure}" "Post-commit snapshot writes that failed and were swallowed." + snapshotApplyDivergence' <- counterI64 keiroSnapshotApplyDivergenceName "{failure}" "Just-appended event batches that failed to replay from the pre-command state; the stream is poisoned and its next hydration will fail." + snapshotSeedDivergence' <- counterI64 keiroSnapshotSeedDivergenceName "{failure}" "Sampled snapshot seeds whose encoded state disagreed with a full replay through the seed version." + dispatchFailed' <- counterI64 keiroDispatchFailedName "{command}" "Process-manager/router dispatch commands that failed." + dispatchDeadlettered' <- counterI64 keiroDispatchDeadletteredName "{command}" "Rejected process-manager/router dispatch commands handled by dead-letter or skip policy." + subscriptionDeadlettered' <- counterI64 keiroSubscriptionDeadletteredName "{event}" "Kiroku source events dead-lettered by an explicit disposition or retry exhaustion." + dispatchDuplicates' <- counterI64 keiroDispatchDuplicatesName "{command}" "Process-manager/router dispatch commands skipped as duplicate deterministic event ids." + dispatchPoison' <- counterI64 keiroDispatchPoisonName "{message}" "Process-manager/router worker messages classified as poison." + workflowStepsExecuted' <- counterI64 keiroWorkflowStepsExecutedName "{step}" "Workflow steps that ran their action (a journal miss)." + workflowStepsReplayed' <- counterI64 keiroWorkflowStepsReplayedName "{step}" "Workflow steps short-circuited to a recorded result (a journal hit)." + workflowResumed' <- counterI64 keiroWorkflowResumedName "{workflow}" "Workflow re-invocations performed by the resume worker." + workflowFailed' <- counterI64 keiroWorkflowFailedName "{workflow}" "Workflow instances marked terminally failed by the resume worker." + workflowResumeErrors' <- counterI64 keiroWorkflowResumeErrorsName "{error}" "Transient store errors observed by the workflow resume worker." + workflowLeaseSkipped' <- counterI64 keiroWorkflowLeaseSkippedName "{workflow}" "Workflow instances skipped because another worker owns their lease." + workflowActive' <- gaugeI64 keiroWorkflowActiveName "{workflow}" "Workflow runs currently in progress in this process." + workflowJournalLength' <- histogram keiroWorkflowJournalLengthName "{event}" "Journal event count of a workflow at completion." + workflowAwakeablesPending' <- gaugeI64 keiroWorkflowAwakeablesPendingName "{awakeable}" "Awakeables awaiting an external signal." + pure + KeiroMetrics + { outboxBacklog = outboxBacklog', + outboxPublished = outboxPublished', + outboxRetried = outboxRetried', + outboxDeadlettered = outboxDeadlettered', + outboxReclaimed = outboxReclaimed', + inboxProcessed = inboxProcessed', + inboxDuplicates = inboxDuplicates', + inboxFailed = inboxFailed', + inboxPoisoned = inboxPoisoned', + inboxBacklog = inboxBacklog', + timerBacklog = timerBacklog', + timerFireLag = timerFireLag', + timerAttempts = timerAttempts', + timerStuck = timerStuck', + timerRequeued = timerRequeued', + projectionLag = projectionLag', + projectionWaitTimeouts = projectionWaitTimeouts', + commandConflicts = commandConflicts', + commandRetries = commandRetries', + commandDuplicates = commandDuplicates', + snapshotDecodeFailures = snapshotDecodeFailures', + snapshotEncodeFailures = snapshotEncodeFailures', + snapshotReadHits = snapshotReadHits', + snapshotReadMisses = snapshotReadMisses', + snapshotWriteFailures = snapshotWriteFailures', + snapshotApplyDivergence = snapshotApplyDivergence', + snapshotSeedDivergence = snapshotSeedDivergence', + dispatchFailed = dispatchFailed', + dispatchDeadlettered = dispatchDeadlettered', + subscriptionDeadlettered = subscriptionDeadlettered', + dispatchDuplicates = dispatchDuplicates', + dispatchPoison = dispatchPoison', + workflowStepsExecuted = workflowStepsExecuted', + workflowStepsReplayed = workflowStepsReplayed', + workflowResumed = workflowResumed', + workflowFailed = workflowFailed', + workflowResumeErrors = workflowResumeErrors', + workflowLeaseSkipped = workflowLeaseSkipped', + workflowActive = workflowActive', + workflowJournalLength = workflowJournalLength', + workflowAwakeablesPending = workflowAwakeablesPending' + } where counterI64 :: Text -> Text -> Text -> IO (Counter Int64) counterI64 name unit desc = - meterCreateCounterInt64 meter name (Just unit) (Just desc) defaultAdvisoryParameters + meterCreateCounterInt64 meter name (Just unit) (Just desc) defaultAdvisoryParameters gaugeI64 :: Text -> Text -> Text -> IO (Gauge Int64) gaugeI64 name unit desc = - meterCreateGaugeInt64 meter name (Just unit) (Just desc) defaultAdvisoryParameters + meterCreateGaugeInt64 meter name (Just unit) (Just desc) defaultAdvisoryParameters histogram :: Text -> Text -> Text -> IO Histogram histogram name unit desc = - meterCreateHistogram meter name (Just unit) (Just desc) defaultAdvisoryParameters + meterCreateHistogram meter name (Just unit) (Just desc) defaultAdvisoryParameters -- Internal: record an Int64 on the counter selected by @sel@, or do nothing. recordCounter :: - (MonadIO m) => (KeiroMetrics -> Counter Int64) -> Maybe KeiroMetrics -> Int64 -> m () + (MonadIO m) => (KeiroMetrics -> Counter Int64) -> Maybe KeiroMetrics -> Int64 -> m () recordCounter _ Nothing _ = pure () recordCounter sel (Just ms) n = liftIO (counterAdd (sel ms) n emptyAttributes) -- Internal: record an Int64 on the gauge selected by @sel@, or do nothing. recordGaugeI64 :: - (MonadIO m) => (KeiroMetrics -> Gauge Int64) -> Maybe KeiroMetrics -> Int64 -> m () + (MonadIO m) => (KeiroMetrics -> Gauge Int64) -> Maybe KeiroMetrics -> Int64 -> m () recordGaugeI64 _ Nothing _ = pure () recordGaugeI64 sel (Just ms) n = liftIO (gaugeRecord (sel ms) n emptyAttributes) -- Internal: record a Double on the histogram selected by @sel@, or do nothing. recordHistogram :: - (MonadIO m) => (KeiroMetrics -> Histogram) -> Maybe KeiroMetrics -> Double -> m () + (MonadIO m) => (KeiroMetrics -> Histogram) -> Maybe KeiroMetrics -> Double -> m () recordHistogram _ Nothing _ = pure () recordHistogram sel (Just ms) v = liftIO (histogramRecord (sel ms) v emptyAttributes) recordOutboxBacklog :: (MonadIO m) => Maybe KeiroMetrics -> Int64 -> m () recordOutboxBacklog = recordGaugeI64 outboxBacklog + recordOutboxPublished :: (MonadIO m) => Maybe KeiroMetrics -> Int64 -> m () recordOutboxPublished = recordCounter outboxPublished + recordOutboxRetried :: (MonadIO m) => Maybe KeiroMetrics -> Int64 -> m () recordOutboxRetried = recordCounter outboxRetried + recordOutboxDeadlettered :: (MonadIO m) => Maybe KeiroMetrics -> Int64 -> m () recordOutboxDeadlettered = recordCounter outboxDeadlettered + recordOutboxReclaimed :: (MonadIO m) => Maybe KeiroMetrics -> Int64 -> m () recordOutboxReclaimed = recordCounter outboxReclaimed + recordInboxProcessed :: (MonadIO m) => Maybe KeiroMetrics -> Int64 -> m () recordInboxProcessed = recordCounter inboxProcessed + recordInboxDuplicates :: (MonadIO m) => Maybe KeiroMetrics -> Int64 -> m () recordInboxDuplicates = recordCounter inboxDuplicates + recordInboxFailed :: (MonadIO m) => Maybe KeiroMetrics -> Int64 -> m () recordInboxFailed = recordCounter inboxFailed + recordInboxPoisoned :: (MonadIO m) => Maybe KeiroMetrics -> Int64 -> m () recordInboxPoisoned = recordCounter inboxPoisoned + recordInboxBacklog :: (MonadIO m) => Maybe KeiroMetrics -> Int64 -> m () recordInboxBacklog = recordGaugeI64 inboxBacklog + recordTimerBacklog :: (MonadIO m) => Maybe KeiroMetrics -> Int64 -> m () recordTimerBacklog = recordGaugeI64 timerBacklog + recordTimerFireLag :: (MonadIO m) => Maybe KeiroMetrics -> Double -> m () recordTimerFireLag = recordHistogram timerFireLag + recordTimerAttempts :: (MonadIO m) => Maybe KeiroMetrics -> Double -> m () recordTimerAttempts = recordHistogram timerAttempts + recordTimerStuck :: (MonadIO m) => Maybe KeiroMetrics -> Int64 -> m () recordTimerStuck = recordGaugeI64 timerStuck + recordTimerRequeued :: (MonadIO m) => Maybe KeiroMetrics -> Int64 -> m () recordTimerRequeued = recordCounter timerRequeued + recordProjectionLag :: (MonadIO m) => Maybe KeiroMetrics -> Int64 -> m () recordProjectionLag = recordGaugeI64 projectionLag + recordProjectionWaitTimeouts :: (MonadIO m) => Maybe KeiroMetrics -> Int64 -> m () recordProjectionWaitTimeouts = recordCounter projectionWaitTimeouts + recordCommandConflicts :: (MonadIO m) => Maybe KeiroMetrics -> Int64 -> m () recordCommandConflicts = recordCounter commandConflicts + recordCommandRetries :: (MonadIO m) => Maybe KeiroMetrics -> Int64 -> m () recordCommandRetries = recordCounter commandRetries + recordCommandDuplicates :: (MonadIO m) => Maybe KeiroMetrics -> Int64 -> m () recordCommandDuplicates = recordCounter commandDuplicates + recordSnapshotDecodeFailures :: (MonadIO m) => Maybe KeiroMetrics -> Int64 -> m () recordSnapshotDecodeFailures = recordCounter snapshotDecodeFailures + recordSnapshotEncodeFailures :: (MonadIO m) => Maybe KeiroMetrics -> Int64 -> m () recordSnapshotEncodeFailures = recordCounter snapshotEncodeFailures + recordSnapshotReadHits :: (MonadIO m) => Maybe KeiroMetrics -> Int64 -> m () recordSnapshotReadHits = recordCounter snapshotReadHits + recordSnapshotReadMisses :: (MonadIO m) => Maybe KeiroMetrics -> Int64 -> m () recordSnapshotReadMisses = recordCounter snapshotReadMisses + recordSnapshotWriteFailures :: (MonadIO m) => Maybe KeiroMetrics -> Int64 -> m () recordSnapshotWriteFailures = recordCounter snapshotWriteFailures + recordSnapshotApplyDivergence :: (MonadIO m) => Maybe KeiroMetrics -> Int64 -> m () recordSnapshotApplyDivergence = recordCounter snapshotApplyDivergence + recordSnapshotSeedDivergence :: (MonadIO m) => Maybe KeiroMetrics -> Int64 -> m () recordSnapshotSeedDivergence = recordCounter snapshotSeedDivergence + recordDispatchFailed :: (MonadIO m) => Maybe KeiroMetrics -> Int64 -> m () recordDispatchFailed = recordCounter dispatchFailed + recordDispatchDeadLettered :: (MonadIO m) => Maybe KeiroMetrics -> Int64 -> m () recordDispatchDeadLettered = recordCounter dispatchDeadlettered + recordSubscriptionDeadLettered :: (MonadIO m) => Maybe KeiroMetrics -> Int64 -> m () recordSubscriptionDeadLettered = recordCounter subscriptionDeadlettered + recordDispatchDuplicate :: (MonadIO m) => Maybe KeiroMetrics -> Int64 -> m () recordDispatchDuplicate = recordCounter dispatchDuplicates + recordDispatchPoison :: (MonadIO m) => Maybe KeiroMetrics -> Int64 -> m () recordDispatchPoison = recordCounter dispatchPoison + recordWorkflowStepExecuted :: (MonadIO m) => Maybe KeiroMetrics -> Int64 -> m () recordWorkflowStepExecuted = recordCounter workflowStepsExecuted + recordWorkflowStepReplayed :: (MonadIO m) => Maybe KeiroMetrics -> Int64 -> m () recordWorkflowStepReplayed = recordCounter workflowStepsReplayed + recordWorkflowResumed :: (MonadIO m) => Maybe KeiroMetrics -> Int64 -> m () recordWorkflowResumed = recordCounter workflowResumed + recordWorkflowFailed :: (MonadIO m) => Maybe KeiroMetrics -> Int64 -> m () recordWorkflowFailed = recordCounter workflowFailed + recordWorkflowResumeErrors :: (MonadIO m) => Maybe KeiroMetrics -> Int64 -> m () recordWorkflowResumeErrors = recordCounter workflowResumeErrors + recordWorkflowLeaseSkipped :: (MonadIO m) => Maybe KeiroMetrics -> Int64 -> m () recordWorkflowLeaseSkipped = recordCounter workflowLeaseSkipped + recordWorkflowActive :: (MonadIO m) => Maybe KeiroMetrics -> Int64 -> m () recordWorkflowActive = recordGaugeI64 workflowActive + recordWorkflowJournalLength :: (MonadIO m) => Maybe KeiroMetrics -> Double -> m () recordWorkflowJournalLength = recordHistogram workflowJournalLength + recordWorkflowAwakeablesPending :: (MonadIO m) => Maybe KeiroMetrics -> Int64 -> m () recordWorkflowAwakeablesPending = recordGaugeI64 workflowAwakeablesPending -{- | Feed Kiroku store events into Keiro metrics, then delegate every event to -the application's existing event handler. Install this as (or inside) the -@eventHandler@ on Kiroku's @ConnectionSettings@ at store construction; pass -@const (pure ())@ when there is no other handler. - -'KirokuEventSubscriptionDeadLettered' is the terminal retry-exhaustion signal: -the acknowledgement bridge exposes the current delivery attempt, but does not -tell a handler that its retry reply consumed the final attempt. For current -dead-letter depth, query Kiroku's durable table rather than treating this -monotonic counter as a gauge: - -> SELECT count(*) FROM kiroku.dead_letters WHERE subscription_name = $1 - -The delegate runs synchronously, matching Kiroku's event-handler contract, so -it should remain fast and non-blocking. --} +-- | Feed Kiroku store events into Keiro metrics, then delegate every event to +-- the application's existing event handler. Install this as (or inside) the +-- @eventHandler@ on Kiroku's @ConnectionSettings@ at store construction; pass +-- @const (pure ())@ when there is no other handler. +-- +-- 'KirokuEventSubscriptionDeadLettered' is the terminal retry-exhaustion signal: +-- the acknowledgement bridge exposes the current delivery attempt, but does not +-- tell a handler that its retry reply consumed the final attempt. For current +-- dead-letter depth, query Kiroku's durable table rather than treating this +-- monotonic counter as a gauge: +-- +-- > SELECT count(*) FROM kiroku.dead_letters WHERE subscription_name = $1 +-- +-- The delegate runs synchronously, matching Kiroku's event-handler contract, so +-- it should remain fast and non-blocking. kirokuEventBridge :: Maybe KeiroMetrics -> (KirokuEvent -> IO ()) -> KirokuEvent -> IO () kirokuEventBridge metrics delegate event = do - case event of - KirokuEventSubscriptionDeadLettered{} -> recordSubscriptionDeadLettered metrics 1 - _ -> pure () - delegate event + case event of + KirokuEventSubscriptionDeadLettered {} -> recordSubscriptionDeadLettered metrics 1 + _ -> pure () + delegate event diff --git a/src/Keiro/Timer.hs b/src/Keiro/Timer.hs --- a/src/Keiro/Timer.hs +++ b/src/Keiro/Timer.hs @@ -1,20 +1,19 @@ -{- | Durable timers for process managers. - -A process manager schedules a timer ('scheduleTimerTx', in its own append -transaction) to be woken at a future time — a saga timeout, a retry delay, a -deadline. The 'runTimerWorker' loop claims one due timer at a time with -@FOR UPDATE SKIP LOCKED@ (so multiple workers can run safely), hands it to a -caller-supplied @fire@ action that typically dispatches a command back into -the manager, and marks it fired once the resulting event id is known. A -timer left @Firing@ by a crash becomes claimable again after the worker's -configured stale-claim timeout, giving at-least-once firing. - -The wire types live in "Keiro.Timer.Types" and the SQL storage in -"Keiro.Timer.Schema"; both are re-exported here so most callers need only -import @Keiro.Timer@. --} -module Keiro.Timer ( - -- * Timer types +-- | Durable timers for process managers. +-- +-- A process manager schedules a timer ('scheduleTimerTx', in its own append +-- transaction) to be woken at a future time — a saga timeout, a retry delay, a +-- deadline. The 'runTimerWorker' loop claims one due timer at a time with +-- @FOR UPDATE SKIP LOCKED@ (so multiple workers can run safely), hands it to a +-- caller-supplied @fire@ action that typically dispatches a command back into +-- the manager, and marks it fired once the resulting event id is known. A +-- timer left @Firing@ by a crash becomes claimable again after the worker's +-- configured stale-claim timeout, giving at-least-once firing. +-- +-- The wire types live in "Keiro.Timer.Types" and the SQL storage in +-- "Keiro.Timer.Schema"; both are re-exported here so most callers need only +-- import @Keiro.Timer@. +module Keiro.Timer + ( -- * Timer types TimerId (..), TimerRequest (..), TimerRow (..), @@ -44,21 +43,21 @@ mkTimerWorkerOptions, runTimerWorker, runTimerWorkerWith, -) + ) where import Data.Text qualified as Text import Data.Time.Clock (NominalDiffTime, diffUTCTime) import Effectful (Eff, IOE, (:>)) import Keiro.Prelude -import Keiro.Telemetry ( - KeiroMetrics, +import Keiro.Telemetry + ( KeiroMetrics, recordTimerAttempts, recordTimerBacklog, recordTimerFireLag, recordTimerRequeued, recordTimerStuck, - ) + ) import Keiro.Timer.Schema import Keiro.Timer.Types import Kiroku.Store.Effect (Store) @@ -66,114 +65,110 @@ -- | Options controlling 'runTimerWorkerWith'. data TimerWorkerOptions = TimerWorkerOptions - { maxAttempts :: Maybe Int - {- ^ When @Just n@, a claimed timer whose post-claim @attempts@ exceeds @n@ is - moved to 'Dead' (via 'deadLetterTimer') instead of being fired. @Nothing@ - never auto-dead-letters (the historical behavior). - -} - , requeueStuckAfter :: !(Maybe NominalDiffTime) - {- ^ When @Just ttl@, each worker pass first moves @Firing@ timers whose - @updated_at@ is at least @ttl@ old back to 'Scheduled'. A fire action that - runs longer than this timeout may be fired again; timer handlers must be - idempotent under keiro's at-least-once timer contract. @Nothing@ disables - automatic requeue for callers that run their own recovery. - -} - } - deriving stock (Generic, Eq, Show) + { -- | When @Just n@, a claimed timer whose post-claim @attempts@ exceeds @n@ is + -- moved to 'Dead' (via 'deadLetterTimer') instead of being fired. @Nothing@ + -- never auto-dead-letters (the historical behavior). + maxAttempts :: Maybe Int, + -- | When @Just ttl@, each worker pass first moves @Firing@ timers whose + -- @updated_at@ is at least @ttl@ old back to 'Scheduled'. A fire action that + -- runs longer than this timeout may be fired again; timer handlers must be + -- idempotent under keiro's at-least-once timer contract. @Nothing@ disables + -- automatic requeue for callers that run their own recovery. + requeueStuckAfter :: !(Maybe NominalDiffTime) + } + deriving stock (Generic, Eq, Show) data TimerWorkerConfigError - = InvalidTimerMaxAttempts !Int - | InvalidTimerRequeueStuckAfter !NominalDiffTime - deriving stock (Generic, Eq, Show) + = InvalidTimerMaxAttempts !Int + | InvalidTimerRequeueStuckAfter !NominalDiffTime + deriving stock (Generic, Eq, Show) -- | The default worker policy: never auto-dead-letter; requeue stale firings after five minutes. defaultTimerWorkerOptions :: TimerWorkerOptions -defaultTimerWorkerOptions = TimerWorkerOptions{maxAttempts = Nothing, requeueStuckAfter = Just 300} +defaultTimerWorkerOptions = TimerWorkerOptions {maxAttempts = Nothing, requeueStuckAfter = Just 300} -- | Validate timer worker options before starting a worker loop. mkTimerWorkerOptions :: TimerWorkerOptions -> Either TimerWorkerConfigError TimerWorkerOptions mkTimerWorkerOptions opts = - case (opts ^. #maxAttempts, opts ^. #requeueStuckAfter) of - (Just attempts, _) | attempts < 0 -> Left (InvalidTimerMaxAttempts attempts) - (_, Just ttl) | ttl <= 0 -> Left (InvalidTimerRequeueStuckAfter ttl) - _ -> Right opts - -{- | Claim and fire at most one timer due at @now@, applying the given -'TimerWorkerOptions'. - -Atomically claims the earliest due timer (marking it @Firing@). If the options -set @maxAttempts = Just n@ and the timer's post-claim @attempts@ exceeds @n@, it -is dead-lettered ('Dead', with an explanatory @last_error@) instead of fired — -rather than ping-ponging forever on a timer that never completes. Before -claiming, the worker requeues stale @Firing@ rows according to -'requeueStuckAfter'. Otherwise the caller's @fire@ action runs and — if it -returns the id of the event it produced — the timer is marked @Fired@. Returns -the claimed 'TimerRow' (the row as claimed, before any dead-letter or fire -UPDATE), or 'Nothing' when nothing is due. A @fire@ that returns 'Nothing' -leaves the timer @Firing@ until it becomes stale and is requeued on a later -worker pass. - -A timer may fire more than once if a worker crashes after the external action -but before 'markTimerFired', or if @fire@ takes longer than 'requeueStuckAfter'. -Handlers must therefore be idempotent. + case (opts ^. #maxAttempts, opts ^. #requeueStuckAfter) of + (Just attempts, _) | attempts < 0 -> Left (InvalidTimerMaxAttempts attempts) + (_, Just ttl) | ttl <= 0 -> Left (InvalidTimerRequeueStuckAfter ttl) + _ -> Right opts -Note 'claimDueTimer' increments @attempts@ before this check, so the comparison -sees the post-claim count: with @maxAttempts = Just 0@ the very first claim -dead-letters; with @Just 2@ the third claim does. --} +-- | Claim and fire at most one timer due at @now@, applying the given +-- 'TimerWorkerOptions'. +-- +-- Atomically claims the earliest due timer (marking it @Firing@). If the options +-- set @maxAttempts = Just n@ and the timer's post-claim @attempts@ exceeds @n@, it +-- is dead-lettered ('Dead', with an explanatory @last_error@) instead of fired — +-- rather than ping-ponging forever on a timer that never completes. Before +-- claiming, the worker requeues stale @Firing@ rows according to +-- 'requeueStuckAfter'. Otherwise the caller's @fire@ action runs and — if it +-- returns the id of the event it produced — the timer is marked @Fired@. Returns +-- the claimed 'TimerRow' (the row as claimed, before any dead-letter or fire +-- UPDATE), or 'Nothing' when nothing is due. A @fire@ that returns 'Nothing' +-- leaves the timer @Firing@ until it becomes stale and is requeued on a later +-- worker pass. +-- +-- A timer may fire more than once if a worker crashes after the external action +-- but before 'markTimerFired', or if @fire@ takes longer than 'requeueStuckAfter'. +-- Handlers must therefore be idempotent. +-- +-- Note 'claimDueTimer' increments @attempts@ before this check, so the comparison +-- sees the post-claim count: with @maxAttempts = Just 0@ the very first claim +-- dead-letters; with @Just 2@ the third claim does. runTimerWorkerWith :: - (IOE :> es, Store :> es) => - Maybe KeiroMetrics -> - TimerWorkerOptions -> - UTCTime -> - (TimerRow -> Eff es (Maybe EventId)) -> - Eff es (Maybe TimerRow) + (IOE :> es, Store :> es) => + Maybe KeiroMetrics -> + TimerWorkerOptions -> + UTCTime -> + (TimerRow -> Eff es (Maybe EventId)) -> + Eff es (Maybe TimerRow) runTimerWorkerWith metrics options now fire = do - for_ (options ^. #requeueStuckAfter) $ \ttl -> do - requeued <- requeueStuckTimers ttl now - recordTimerRequeued metrics (fromIntegral requeued) - -- Gauges recorded once per pass, before the claim, off the counts the worker - -- already needs its 'Store' for: the backlog as the worker sees it at the - -- start of the pass (including the row it is about to claim), and the number - -- of rows stranded in 'Firing' by earlier passes that never completed. Each - -- is a no-op under a 'Nothing' handle. - backlog <- countDueTimers now - recordTimerBacklog metrics (fromIntegral backlog) - stuck <- countStuckTimers now anyStuckTimer - recordTimerStuck metrics (fromIntegral stuck) - due <- claimDueTimer now - case due of - Nothing -> pure Nothing - Just timer -> do - -- Histograms for the claimed timer: how late it fired and how many - -- attempts it has now taken. EP-33 declared 'keiro.timer.fire.lag' in - -- milliseconds, so the seconds 'diffUTCTime' yields are scaled by 1000. - -- The lag is non-negative because only fire_at <= now rows are claimable. - recordTimerFireLag metrics (realToFrac (now `diffUTCTime` (timer ^. #fireAt)) * 1000) - recordTimerAttempts metrics (fromIntegral (timer ^. #attempts)) - case options ^. #maxAttempts of - Just attemptCeiling - | (timer ^. #attempts) > attemptCeiling -> do - _ <- - deadLetterTimer - (timer ^. #timerId) - ("timer exceeded attempt ceiling of " <> Text.pack (show attemptCeiling)) - pure (Just timer) - _ -> do - fired <- fire timer - for_ fired (\eventId -> void (markTimerFired (timer ^. #timerId) eventId)) - pure (Just timer) + for_ (options ^. #requeueStuckAfter) $ \ttl -> do + requeued <- requeueStuckTimers ttl now + recordTimerRequeued metrics (fromIntegral requeued) + -- Gauges recorded once per pass, before the claim, off the counts the worker + -- already needs its 'Store' for: the backlog as the worker sees it at the + -- start of the pass (including the row it is about to claim), and the number + -- of rows stranded in 'Firing' by earlier passes that never completed. Each + -- is a no-op under a 'Nothing' handle. + backlog <- countDueTimers now + recordTimerBacklog metrics (fromIntegral backlog) + stuck <- countStuckTimers now anyStuckTimer + recordTimerStuck metrics (fromIntegral stuck) + due <- claimDueTimer now + case due of + Nothing -> pure Nothing + Just timer -> do + -- Histograms for the claimed timer: how late it fired and how many + -- attempts it has now taken. EP-33 declared 'keiro.timer.fire.lag' in + -- milliseconds, so the seconds 'diffUTCTime' yields are scaled by 1000. + -- The lag is non-negative because only fire_at <= now rows are claimable. + recordTimerFireLag metrics (realToFrac (now `diffUTCTime` (timer ^. #fireAt)) * 1000) + recordTimerAttempts metrics (fromIntegral (timer ^. #attempts)) + case options ^. #maxAttempts of + Just attemptCeiling + | (timer ^. #attempts) > attemptCeiling -> do + _ <- + deadLetterTimer + (timer ^. #timerId) + ("timer exceeded attempt ceiling of " <> Text.pack (show attemptCeiling)) + pure (Just timer) + _ -> do + fired <- fire timer + for_ fired (\eventId -> void (markTimerFired (timer ^. #timerId) eventId)) + pure (Just timer) -{- | Claim and fire at most one timer due at @now@ using -'defaultTimerWorkerOptions' (no attempt ceiling). Equivalent to -@'runTimerWorkerWith' 'defaultTimerWorkerOptions'@; the default has no attempt -ceiling and requeues claims left @Firing@ for five minutes. See -'runTimerWorkerWith' for the full semantics. --} +-- | Claim and fire at most one timer due at @now@ using +-- 'defaultTimerWorkerOptions' (no attempt ceiling). Equivalent to +-- @'runTimerWorkerWith' 'defaultTimerWorkerOptions'@; the default has no attempt +-- ceiling and requeues claims left @Firing@ for five minutes. See +-- 'runTimerWorkerWith' for the full semantics. runTimerWorker :: - (IOE :> es, Store :> es) => - Maybe KeiroMetrics -> - UTCTime -> - (TimerRow -> Eff es (Maybe EventId)) -> - Eff es (Maybe TimerRow) + (IOE :> es, Store :> es) => + Maybe KeiroMetrics -> + UTCTime -> + (TimerRow -> Eff es (Maybe EventId)) -> + Eff es (Maybe TimerRow) runTimerWorker metrics = runTimerWorkerWith metrics defaultTimerWorkerOptions diff --git a/src/Keiro/Timer/Schema.hs b/src/Keiro/Timer/Schema.hs --- a/src/Keiro/Timer/Schema.hs +++ b/src/Keiro/Timer/Schema.hs @@ -1,18 +1,17 @@ -{- | The @keiro_timers@ table: storage and claim logic for durable timers. - -Holds one row per scheduled timer with its 'TimerStatus' lifecycle. -'scheduleTimerTx' inserts (or re-arms a still-@Scheduled@ timer with the same -id) inside the caller's transaction; 'claimDueTimer' atomically picks the -single earliest due timer with @FOR UPDATE SKIP LOCKED@ and moves it to -@Firing@, so competing workers never claim the same timer; 'markTimerFired' -records completion and the produced event id. Stale @Firing@ rows are requeued -by 'requeueStuckTimers' so a crashed worker does not strand a timer forever. - -Callers normally use the re-exports from "Keiro.Timer" rather than this -module directly. --} -module Keiro.Timer.Schema ( - -- * Rows and status +-- | The @keiro_timers@ table: storage and claim logic for durable timers. +-- +-- Holds one row per scheduled timer with its 'TimerStatus' lifecycle. +-- 'scheduleTimerTx' inserts (or re-arms a still-@Scheduled@ timer with the same +-- id) inside the caller's transaction; 'claimDueTimer' atomically picks the +-- single earliest due timer with @FOR UPDATE SKIP LOCKED@ and moves it to +-- @Firing@, so competing workers never claim the same timer; 'markTimerFired' +-- records completion and the produced event id. Stale @Firing@ rows are requeued +-- by 'requeueStuckTimers' so a crashed worker does not strand a timer forever. +-- +-- Callers normally use the re-exports from "Keiro.Timer" rather than this +-- module directly. +module Keiro.Timer.Schema + ( -- * Rows and status TimerStatus (..), TimerRow (..), @@ -34,7 +33,7 @@ requeueStuckTimer, cancelTimer, deadLetterTimer, -) + ) where import Contravariant.Extras (contrazip2, contrazip6) @@ -51,405 +50,391 @@ import Kiroku.Store.Types (EventId (..)) import "hasql-transaction" Hasql.Transaction qualified as Tx -{- | A timer's lifecycle state. - -* 'Scheduled' — waiting for its 'fireAt'; claimable. -* 'Firing' — claimed by a worker and being processed; stale rows become - claimable again when 'requeueStuckTimers' moves them back to 'Scheduled'. -* 'Fired' — successfully fired; terminal. -* 'Cancelled' — withdrawn before firing. -* 'Dead' — abandoned after exceeding the attempt ceiling; terminal; carries an - optional @last_error@ describing why it was given up on. --} +-- | A timer's lifecycle state. +-- +-- * 'Scheduled' — waiting for its 'fireAt'; claimable. +-- * 'Firing' — claimed by a worker and being processed; stale rows become +-- claimable again when 'requeueStuckTimers' moves them back to 'Scheduled'. +-- * 'Fired' — successfully fired; terminal. +-- * 'Cancelled' — withdrawn before firing. +-- * 'Dead' — abandoned after exceeding the attempt ceiling; terminal; carries an +-- optional @last_error@ describing why it was given up on. data TimerStatus - = Scheduled - | Firing - | Fired - | Cancelled - | Dead - deriving stock (Generic, Eq, Show) + = Scheduled + | Firing + | Fired + | Cancelled + | Dead + deriving stock (Generic, Eq, Show) -{- | A timer row as stored: the original 'TimerRequest' fields plus the live -'status', the 'attempts' count (incremented on each claim), and the -'firedEventId' recorded once it fires. --} +-- | A timer row as stored: the original 'TimerRequest' fields plus the live +-- 'status', the 'attempts' count (incremented on each claim), and the +-- 'firedEventId' recorded once it fires. data TimerRow = TimerRow - { timerId :: !TimerId - , processManagerName :: !Text - , correlationId :: !Text - , fireAt :: !UTCTime - , payload :: !Value - , status :: !TimerStatus - , attempts :: !Int - , firedEventId :: !(Maybe EventId) - } - deriving stock (Generic, Eq, Show) + { timerId :: !TimerId, + processManagerName :: !Text, + correlationId :: !Text, + fireAt :: !UTCTime, + payload :: !Value, + status :: !TimerStatus, + attempts :: !Int, + firedEventId :: !(Maybe EventId) + } + deriving stock (Generic, Eq, Show) -{- | Criteria selecting timers stranded in 'Firing'. A row is "stuck" when its -'status' is @firing@ and it matches every set bound: 'minAge' (it has been -firing at least this long, measured from @updated_at@) and 'minAttempts' (it -has been claimed at least this many times). Both unset selects every @firing@ -row. --} +-- | Criteria selecting timers stranded in 'Firing'. A row is "stuck" when its +-- 'status' is @firing@ and it matches every set bound: 'minAge' (it has been +-- firing at least this long, measured from @updated_at@) and 'minAttempts' (it +-- has been claimed at least this many times). Both unset selects every @firing@ +-- row. data StuckTimerFilter = StuckTimerFilter - { minAge :: !(Maybe NominalDiffTime) - , minAttempts :: !(Maybe Int) - } - deriving stock (Generic, Eq, Show) + { minAge :: !(Maybe NominalDiffTime), + minAttempts :: !(Maybe Int) + } + deriving stock (Generic, Eq, Show) -- | Select every @firing@ row regardless of age or attempts. anyStuckTimer :: StuckTimerFilter anyStuckTimer = StuckTimerFilter Nothing Nothing -{- | Schedule a timer inside the caller's transaction (typically a process -manager's append). Upserts on 'timerId': a conflicting row is re-armed only -while it is still @Scheduled@, so a timer that has already fired or been -cancelled is not resurrected. --} +-- | Schedule a timer inside the caller's transaction (typically a process +-- manager's append). Upserts on 'timerId': a conflicting row is re-armed only +-- while it is still @Scheduled@, so a timer that has already fired or been +-- cancelled is not resurrected. scheduleTimerTx :: TimerRequest -> Tx.Transaction () scheduleTimerTx request = - Tx.statement - ( timerIdToUuid (request ^. #timerId) - , request ^. #processManagerName - , request ^. #correlationId - , request ^. #fireAt - , request ^. #payload - , statusToText Scheduled - ) - scheduleTimerStmt - -{- | Schedule a timer only if no row with the same 'timerId' already exists. + Tx.statement + ( timerIdToUuid (request ^. #timerId), + request ^. #processManagerName, + request ^. #correlationId, + request ^. #fireAt, + request ^. #payload, + statusToText Scheduled + ) + scheduleTimerStmt -This is for callers whose first arm must win, such as durable workflow sleeps: -every resume pass re-runs the sleep arm until the timer fires, and preserving -the original 'fireAt' keeps the sleep measured from the first arm. Process -managers that intentionally push a deadline back should keep using -'scheduleTimerTx'. Returns 'True' when this call inserted the row and 'False' -when an existing timer won. --} +-- | Schedule a timer only if no row with the same 'timerId' already exists. +-- +-- This is for callers whose first arm must win, such as durable workflow sleeps: +-- every resume pass re-runs the sleep arm until the timer fires, and preserving +-- the original 'fireAt' keeps the sleep measured from the first arm. Process +-- managers that intentionally push a deadline back should keep using +-- 'scheduleTimerTx'. Returns 'True' when this call inserted the row and 'False' +-- when an existing timer won. scheduleTimerOnceTx :: TimerRequest -> Tx.Transaction Bool scheduleTimerOnceTx request = - Tx.statement - ( timerIdToUuid (request ^. #timerId) - , request ^. #processManagerName - , request ^. #correlationId - , request ^. #fireAt - , request ^. #payload - , statusToText Scheduled - ) - scheduleTimerOnceStmt + Tx.statement + ( timerIdToUuid (request ^. #timerId), + request ^. #processManagerName, + request ^. #correlationId, + request ^. #fireAt, + request ^. #payload, + statusToText Scheduled + ) + scheduleTimerOnceStmt -{- | Atomically claim the single earliest timer due at @now@, moving it to -@Firing@ and bumping its attempt count. Uses @FOR UPDATE SKIP LOCKED@ so -concurrent workers each get a distinct timer. Returns 'Nothing' when none is -due. --} +-- | Atomically claim the single earliest timer due at @now@, moving it to +-- @Firing@ and bumping its attempt count. Uses @FOR UPDATE SKIP LOCKED@ so +-- concurrent workers each get a distinct timer. Returns 'Nothing' when none is +-- due. claimDueTimer :: (Store :> es) => UTCTime -> Eff es (Maybe TimerRow) claimDueTimer now = - runTransaction $ - Tx.statement now claimDueTimerStmt + runTransaction $ + Tx.statement now claimDueTimerStmt -{- | Mark a claimed timer @Fired@, recording the id of the event its firing -produced. Returns 'False' when the row left @Firing@ while the fire action was -running (for example, it was requeued, cancelled, or dead-lettered). --} +-- | Mark a claimed timer @Fired@, recording the id of the event its firing +-- produced. Returns 'False' when the row left @Firing@ while the fire action was +-- running (for example, it was requeued, cancelled, or dead-lettered). markTimerFired :: (Store :> es) => TimerId -> EventId -> Eff es Bool markTimerFired timerId eventId = - runTransaction $ - Tx.statement (timerIdToUuid timerId, eventIdToUuid eventId) markTimerFiredStmt + runTransaction $ + Tx.statement (timerIdToUuid timerId, eventIdToUuid eventId) markTimerFiredStmt -{- | Count timers that are @scheduled@ and already due at @now@ — the timer -backlog. Read-only; mirrors 'claimDueTimer''s WHERE clause but counts rather -than locking, so it never claims or mutates a row. --} +-- | Count timers that are @scheduled@ and already due at @now@ — the timer +-- backlog. Read-only; mirrors 'claimDueTimer''s WHERE clause but counts rather +-- than locking, so it never claims or mutates a row. countDueTimers :: (Store :> es) => UTCTime -> Eff es Int countDueTimers now = - runTransaction $ - Tx.statement now countDueTimersStmt + runTransaction $ + Tx.statement now countDueTimersStmt -{- | Count timers stranded in @Firing@ that match the given 'StuckTimerFilter' — -the same "stuck" predicate 'findStuckTimers' lists, evaluated against @now@. -Read-only. 'anyStuckTimer' counts every @firing@ row. --} +-- | Count timers stranded in @Firing@ that match the given 'StuckTimerFilter' — +-- the same "stuck" predicate 'findStuckTimers' lists, evaluated against @now@. +-- Read-only. 'anyStuckTimer' counts every @firing@ row. countStuckTimers :: (Store :> es) => UTCTime -> StuckTimerFilter -> Eff es Int countStuckTimers now stuckFilter = - runTransaction $ - Tx.statement (cutoff, fmap fromIntegral (stuckFilter ^. #minAttempts)) countStuckTimersStmt + runTransaction $ + Tx.statement (cutoff, fmap fromIntegral (stuckFilter ^. #minAttempts)) countStuckTimersStmt where cutoff = fmap (\age -> addUTCTime (negate age) now) (stuckFilter ^. #minAge) -{- | List timers stranded in @Firing@ that match the given 'StuckTimerFilter'. -The @minAge@ bound is evaluated against @now@: a row qualifies when its -@updated_at@ is at least @minAge@ in the past (cutoff @now - minAge@). Results -are ordered oldest-first by @updated_at@. --} +-- | List timers stranded in @Firing@ that match the given 'StuckTimerFilter'. +-- The @minAge@ bound is evaluated against @now@: a row qualifies when its +-- @updated_at@ is at least @minAge@ in the past (cutoff @now - minAge@). Results +-- are ordered oldest-first by @updated_at@. findStuckTimers :: - (Store :> es) => UTCTime -> StuckTimerFilter -> Eff es [TimerRow] + (Store :> es) => UTCTime -> StuckTimerFilter -> Eff es [TimerRow] findStuckTimers now stuckFilter = - runTransaction $ - Tx.statement (cutoff, fmap fromIntegral (stuckFilter ^. #minAttempts)) findStuckTimersStmt + runTransaction $ + Tx.statement (cutoff, fmap fromIntegral (stuckFilter ^. #minAttempts)) findStuckTimersStmt where cutoff = fmap (\age -> addUTCTime (negate age) now) (stuckFilter ^. #minAge) -{- | Move every timer stranded in @Firing@ for at least @olderThan@ back to -@Scheduled@. The statement preserves @fire_at@, so a due timer becomes -claimable on the same worker pass. Returns the number of rows requeued. --} +-- | Move every timer stranded in @Firing@ for at least @olderThan@ back to +-- @Scheduled@. The statement preserves @fire_at@, so a due timer becomes +-- claimable on the same worker pass. Returns the number of rows requeued. requeueStuckTimers :: (Store :> es) => NominalDiffTime -> UTCTime -> Eff es Int requeueStuckTimers olderThan now = - runTransaction $ - Tx.statement cutoff requeueStuckTimersStmt + runTransaction $ + Tx.statement cutoff requeueStuckTimersStmt where cutoff = addUTCTime (negate olderThan) now -{- | Move a timer from @Firing@ back to @Scheduled@ so the ordinary claim loop -re-fires it. Leaves @fire_at@ unchanged, so a due timer becomes immediately -re-claimable. Idempotent: only @firing@ rows match, so re-running on an -already-requeued row affects nothing. Returns 'True' when a row changed. --} +-- | Move a timer from @Firing@ back to @Scheduled@ so the ordinary claim loop +-- re-fires it. Leaves @fire_at@ unchanged, so a due timer becomes immediately +-- re-claimable. Idempotent: only @firing@ rows match, so re-running on an +-- already-requeued row affects nothing. Returns 'True' when a row changed. requeueStuckTimer :: (Store :> es) => TimerId -> Eff es Bool requeueStuckTimer timerId = - runTransaction $ - Tx.statement (timerIdToUuid timerId) requeueStuckTimerStmt + runTransaction $ + Tx.statement (timerIdToUuid timerId) requeueStuckTimerStmt -{- | Move a timer from @Scheduled@ or @Firing@ to the terminal @Cancelled@ -state so it never fires. Terminal rows (@fired@, @cancelled@, @dead@) are left -untouched. Idempotent. Returns 'True' when a row changed. --} +-- | Move a timer from @Scheduled@ or @Firing@ to the terminal @Cancelled@ +-- state so it never fires. Terminal rows (@fired@, @cancelled@, @dead@) are left +-- untouched. Idempotent. Returns 'True' when a row changed. cancelTimer :: (Store :> es) => TimerId -> Eff es Bool cancelTimer timerId = - runTransaction $ - Tx.statement (timerIdToUuid timerId) cancelTimerStmt + runTransaction $ + Tx.statement (timerIdToUuid timerId) cancelTimerStmt -{- | Move a timer from @Scheduled@ or @Firing@ to the terminal @Dead@ state, -recording @reason@ in @last_error@ so an operator can see why it was abandoned -(@SELECT * FROM keiro_timers WHERE status = 'dead'@). Terminal rows are left -untouched. Idempotent. Returns 'True' when a row changed. --} +-- | Move a timer from @Scheduled@ or @Firing@ to the terminal @Dead@ state, +-- recording @reason@ in @last_error@ so an operator can see why it was abandoned +-- (@SELECT * FROM keiro_timers WHERE status = 'dead'@). Terminal rows are left +-- untouched. Idempotent. Returns 'True' when a row changed. deadLetterTimer :: (Store :> es) => TimerId -> Text -> Eff es Bool deadLetterTimer timerId reason = - runTransaction $ - Tx.statement (timerIdToUuid timerId, reason) deadLetterTimerStmt + runTransaction $ + Tx.statement (timerIdToUuid timerId, reason) deadLetterTimerStmt scheduleTimerStmt :: Statement (UUID, Text, Text, UTCTime, Value, Text) () scheduleTimerStmt = - preparable - """ - INSERT INTO keiro.keiro_timers - (timer_id, process_manager_name, correlation_id, fire_at, payload, status) - VALUES - ($1, $2, $3, $4, $5, $6) - ON CONFLICT (timer_id) DO UPDATE - SET process_manager_name = EXCLUDED.process_manager_name, - correlation_id = EXCLUDED.correlation_id, - fire_at = EXCLUDED.fire_at, - payload = EXCLUDED.payload, - status = EXCLUDED.status, - updated_at = now() - WHERE keiro_timers.status = 'scheduled' - """ - ( contrazip6 - (E.param (E.nonNullable E.uuid)) - (E.param (E.nonNullable E.text)) - (E.param (E.nonNullable E.text)) - (E.param (E.nonNullable E.timestamptz)) - (E.param (E.nonNullable E.jsonb)) - (E.param (E.nonNullable E.text)) - ) - D.noResult + preparable + """ + INSERT INTO keiro.keiro_timers + (timer_id, process_manager_name, correlation_id, fire_at, payload, status) + VALUES + ($1, $2, $3, $4, $5, $6) + ON CONFLICT (timer_id) DO UPDATE + SET process_manager_name = EXCLUDED.process_manager_name, + correlation_id = EXCLUDED.correlation_id, + fire_at = EXCLUDED.fire_at, + payload = EXCLUDED.payload, + status = EXCLUDED.status, + updated_at = now() + WHERE keiro_timers.status = 'scheduled' + """ + ( contrazip6 + (E.param (E.nonNullable E.uuid)) + (E.param (E.nonNullable E.text)) + (E.param (E.nonNullable E.text)) + (E.param (E.nonNullable E.timestamptz)) + (E.param (E.nonNullable E.jsonb)) + (E.param (E.nonNullable E.text)) + ) + D.noResult scheduleTimerOnceStmt :: Statement (UUID, Text, Text, UTCTime, Value, Text) Bool scheduleTimerOnceStmt = - preparable - """ - INSERT INTO keiro.keiro_timers - (timer_id, process_manager_name, correlation_id, fire_at, payload, status) - VALUES - ($1, $2, $3, $4, $5, $6) - ON CONFLICT (timer_id) DO NOTHING - """ - ( contrazip6 - (E.param (E.nonNullable E.uuid)) - (E.param (E.nonNullable E.text)) - (E.param (E.nonNullable E.text)) - (E.param (E.nonNullable E.timestamptz)) - (E.param (E.nonNullable E.jsonb)) - (E.param (E.nonNullable E.text)) - ) - ((> 0) <$> D.rowsAffected) + preparable + """ + INSERT INTO keiro.keiro_timers + (timer_id, process_manager_name, correlation_id, fire_at, payload, status) + VALUES + ($1, $2, $3, $4, $5, $6) + ON CONFLICT (timer_id) DO NOTHING + """ + ( contrazip6 + (E.param (E.nonNullable E.uuid)) + (E.param (E.nonNullable E.text)) + (E.param (E.nonNullable E.text)) + (E.param (E.nonNullable E.timestamptz)) + (E.param (E.nonNullable E.jsonb)) + (E.param (E.nonNullable E.text)) + ) + ((> 0) <$> D.rowsAffected) claimDueTimerStmt :: Statement UTCTime (Maybe TimerRow) claimDueTimerStmt = - preparable - """ - WITH due AS ( - SELECT timer_id - FROM keiro.keiro_timers - WHERE status = 'scheduled' - AND fire_at <= $1 - ORDER BY fire_at, timer_id - LIMIT 1 - FOR UPDATE SKIP LOCKED - ) - UPDATE keiro.keiro_timers kt - SET status = 'firing', - attempts = kt.attempts + 1, - updated_at = now() - FROM due - WHERE kt.timer_id = due.timer_id - RETURNING kt.timer_id, kt.process_manager_name, kt.correlation_id, kt.fire_at, - kt.payload, kt.status, kt.attempts, kt.fired_event_id - """ - (E.param (E.nonNullable E.timestamptz)) - (D.rowMaybe timerRowDecoder) + preparable + """ + WITH due AS ( + SELECT timer_id + FROM keiro.keiro_timers + WHERE status = 'scheduled' + AND fire_at <= $1 + ORDER BY fire_at, timer_id + LIMIT 1 + FOR UPDATE SKIP LOCKED + ) + UPDATE keiro.keiro_timers kt + SET status = 'firing', + attempts = kt.attempts + 1, + updated_at = now() + FROM due + WHERE kt.timer_id = due.timer_id + RETURNING kt.timer_id, kt.process_manager_name, kt.correlation_id, kt.fire_at, + kt.payload, kt.status, kt.attempts, kt.fired_event_id + """ + (E.param (E.nonNullable E.timestamptz)) + (D.rowMaybe timerRowDecoder) markTimerFiredStmt :: Statement (UUID, UUID) Bool markTimerFiredStmt = - preparable - """ - UPDATE keiro.keiro_timers - SET status = 'fired', - fired_event_id = $2, - updated_at = now() - WHERE timer_id = $1 - AND status = 'firing' - """ - ( contrazip2 - (E.param (E.nonNullable E.uuid)) - (E.param (E.nonNullable E.uuid)) - ) - ((> 0) <$> D.rowsAffected) + preparable + """ + UPDATE keiro.keiro_timers + SET status = 'fired', + fired_event_id = $2, + updated_at = now() + WHERE timer_id = $1 + AND status = 'firing' + """ + ( contrazip2 + (E.param (E.nonNullable E.uuid)) + (E.param (E.nonNullable E.uuid)) + ) + ((> 0) <$> D.rowsAffected) countDueTimersStmt :: Statement UTCTime Int countDueTimersStmt = - preparable - """ - SELECT count(*) - FROM keiro.keiro_timers - WHERE status = 'scheduled' - AND fire_at <= $1 - """ - (E.param (E.nonNullable E.timestamptz)) - (D.singleRow (fromIntegral <$> D.column (D.nonNullable D.int8))) + preparable + """ + SELECT count(*) + FROM keiro.keiro_timers + WHERE status = 'scheduled' + AND fire_at <= $1 + """ + (E.param (E.nonNullable E.timestamptz)) + (D.singleRow (fromIntegral <$> D.column (D.nonNullable D.int8))) countStuckTimersStmt :: Statement (Maybe UTCTime, Maybe Int64) Int countStuckTimersStmt = - preparable - """ - SELECT count(*) - FROM keiro.keiro_timers - WHERE status = 'firing' - AND ($1::timestamptz IS NULL OR updated_at <= $1) - AND ($2::bigint IS NULL OR attempts >= $2) - """ - ( contrazip2 - (E.param (E.nullable E.timestamptz)) - (E.param (E.nullable E.int8)) - ) - (D.singleRow (fromIntegral <$> D.column (D.nonNullable D.int8))) + preparable + """ + SELECT count(*) + FROM keiro.keiro_timers + WHERE status = 'firing' + AND ($1::timestamptz IS NULL OR updated_at <= $1) + AND ($2::bigint IS NULL OR attempts >= $2) + """ + ( contrazip2 + (E.param (E.nullable E.timestamptz)) + (E.param (E.nullable E.int8)) + ) + (D.singleRow (fromIntegral <$> D.column (D.nonNullable D.int8))) findStuckTimersStmt :: Statement (Maybe UTCTime, Maybe Int64) [TimerRow] findStuckTimersStmt = - preparable - """ - SELECT timer_id, process_manager_name, correlation_id, fire_at, - payload, status, attempts, fired_event_id - FROM keiro.keiro_timers - WHERE status = 'firing' - AND ($1::timestamptz IS NULL OR updated_at <= $1) - AND ($2::bigint IS NULL OR attempts >= $2) - ORDER BY updated_at, timer_id - """ - ( contrazip2 - (E.param (E.nullable E.timestamptz)) - (E.param (E.nullable E.int8)) - ) - (D.rowList timerRowDecoder) + preparable + """ + SELECT timer_id, process_manager_name, correlation_id, fire_at, + payload, status, attempts, fired_event_id + FROM keiro.keiro_timers + WHERE status = 'firing' + AND ($1::timestamptz IS NULL OR updated_at <= $1) + AND ($2::bigint IS NULL OR attempts >= $2) + ORDER BY updated_at, timer_id + """ + ( contrazip2 + (E.param (E.nullable E.timestamptz)) + (E.param (E.nullable E.int8)) + ) + (D.rowList timerRowDecoder) requeueStuckTimersStmt :: Statement UTCTime Int requeueStuckTimersStmt = - preparable - """ - UPDATE keiro.keiro_timers - SET status = 'scheduled', - updated_at = now() - WHERE status = 'firing' - AND updated_at <= $1 - """ - (E.param (E.nonNullable E.timestamptz)) - (fromIntegral <$> D.rowsAffected) + preparable + """ + UPDATE keiro.keiro_timers + SET status = 'scheduled', + updated_at = now() + WHERE status = 'firing' + AND updated_at <= $1 + """ + (E.param (E.nonNullable E.timestamptz)) + (fromIntegral <$> D.rowsAffected) requeueStuckTimerStmt :: Statement UUID Bool requeueStuckTimerStmt = - preparable - """ - UPDATE keiro.keiro_timers - SET status = 'scheduled', - updated_at = now() - WHERE timer_id = $1 - AND status = 'firing' - """ - (E.param (E.nonNullable E.uuid)) - ((> 0) <$> D.rowsAffected) + preparable + """ + UPDATE keiro.keiro_timers + SET status = 'scheduled', + updated_at = now() + WHERE timer_id = $1 + AND status = 'firing' + """ + (E.param (E.nonNullable E.uuid)) + ((> 0) <$> D.rowsAffected) cancelTimerStmt :: Statement UUID Bool cancelTimerStmt = - preparable - """ - UPDATE keiro.keiro_timers - SET status = 'cancelled', - updated_at = now() - WHERE timer_id = $1 - AND status IN ('scheduled', 'firing') - """ - (E.param (E.nonNullable E.uuid)) - ((> 0) <$> D.rowsAffected) + preparable + """ + UPDATE keiro.keiro_timers + SET status = 'cancelled', + updated_at = now() + WHERE timer_id = $1 + AND status IN ('scheduled', 'firing') + """ + (E.param (E.nonNullable E.uuid)) + ((> 0) <$> D.rowsAffected) deadLetterTimerStmt :: Statement (UUID, Text) Bool deadLetterTimerStmt = - preparable - """ - UPDATE keiro.keiro_timers - SET status = 'dead', - last_error = $2, - updated_at = now() - WHERE timer_id = $1 - AND status IN ('scheduled', 'firing') - """ - ( contrazip2 - (E.param (E.nonNullable E.uuid)) - (E.param (E.nonNullable E.text)) - ) - ((> 0) <$> D.rowsAffected) + preparable + """ + UPDATE keiro.keiro_timers + SET status = 'dead', + last_error = $2, + updated_at = now() + WHERE timer_id = $1 + AND status IN ('scheduled', 'firing') + """ + ( contrazip2 + (E.param (E.nonNullable E.uuid)) + (E.param (E.nonNullable E.text)) + ) + ((> 0) <$> D.rowsAffected) timerRowDecoder :: D.Row TimerRow timerRowDecoder = - TimerRow - <$> (TimerId <$> D.column (D.nonNullable D.uuid)) - <*> D.column (D.nonNullable D.text) - <*> D.column (D.nonNullable D.text) - <*> D.column (D.nonNullable D.timestamptz) - <*> D.column (D.nonNullable D.jsonb) - <*> D.column (D.nonNullable (D.refine statusFromText D.text)) - <*> (fromIntegral <$> D.column (D.nonNullable D.int8)) - <*> (fmap EventId <$> D.column (D.nullable D.uuid)) + TimerRow + <$> (TimerId <$> D.column (D.nonNullable D.uuid)) + <*> D.column (D.nonNullable D.text) + <*> D.column (D.nonNullable D.text) + <*> D.column (D.nonNullable D.timestamptz) + <*> D.column (D.nonNullable D.jsonb) + <*> D.column (D.nonNullable (D.refine statusFromText D.text)) + <*> (fromIntegral <$> D.column (D.nonNullable D.int8)) + <*> (fmap EventId <$> D.column (D.nullable D.uuid)) statusToText :: TimerStatus -> Text statusToText = \case - Scheduled -> "scheduled" - Firing -> "firing" - Fired -> "fired" - Cancelled -> "cancelled" - Dead -> "dead" + Scheduled -> "scheduled" + Firing -> "firing" + Fired -> "fired" + Cancelled -> "cancelled" + Dead -> "dead" statusFromText :: Text -> Either Text TimerStatus statusFromText = \case - "scheduled" -> Right Scheduled - "firing" -> Right Firing - "fired" -> Right Fired - "cancelled" -> Right Cancelled - "dead" -> Right Dead - other -> Left ("unknown keiro_timers.status: " <> other) + "scheduled" -> Right Scheduled + "firing" -> Right Firing + "fired" -> Right Fired + "cancelled" -> Right Cancelled + "dead" -> Right Dead + other -> Left ("unknown keiro_timers.status: " <> other) timerIdToUuid :: TimerId -> UUID timerIdToUuid (TimerId uuid) = uuid diff --git a/src/Keiro/Timer/Types.hs b/src/Keiro/Timer/Types.hs --- a/src/Keiro/Timer/Types.hs +++ b/src/Keiro/Timer/Types.hs @@ -1,35 +1,32 @@ -{- | Identity and request types for durable timers, separated from their SQL -storage ("Keiro.Timer.Schema") so process-manager code can construct timer -requests without depending on the persistence layer. --} -module Keiro.Timer.Types ( - TimerId (..), +-- | Identity and request types for durable timers, separated from their SQL +-- storage ("Keiro.Timer.Schema") so process-manager code can construct timer +-- requests without depending on the persistence layer. +module Keiro.Timer.Types + ( TimerId (..), TimerRequest (..), -) + ) where import Data.UUID (UUID) import Keiro.Prelude -{- | A timer's stable identifier. A caller-chosen id makes scheduling -idempotent (rescheduling the same id updates rather than duplicates). --} +-- | A timer's stable identifier. A caller-chosen id makes scheduling +-- idempotent (rescheduling the same id updates rather than duplicates). newtype TimerId = TimerId UUID - deriving stock (Generic, Eq, Ord, Show) - -{- | A request to schedule a timer. + deriving stock (Generic, Eq, Ord, Show) -* 'timerId' — stable id; rescheduling the same id is idempotent. -* 'processManagerName' \/ 'correlationId' — identify the saga instance the - timer belongs to, so the firing can be routed back to it. -* 'fireAt' — the earliest time the timer becomes due. -* 'payload' — opaque JSON carried through to the @fire@ action. --} +-- | A request to schedule a timer. +-- +-- * 'timerId' — stable id; rescheduling the same id is idempotent. +-- * 'processManagerName' \/ 'correlationId' — identify the saga instance the +-- timer belongs to, so the firing can be routed back to it. +-- * 'fireAt' — the earliest time the timer becomes due. +-- * 'payload' — opaque JSON carried through to the @fire@ action. data TimerRequest = TimerRequest - { timerId :: !TimerId - , processManagerName :: !Text - , correlationId :: !Text - , fireAt :: !UTCTime - , payload :: !Value - } - deriving stock (Generic, Eq, Show) + { timerId :: !TimerId, + processManagerName :: !Text, + correlationId :: !Text, + fireAt :: !UTCTime, + payload :: !Value + } + deriving stock (Generic, Eq, Show) diff --git a/src/Keiro/Wake.hs b/src/Keiro/Wake.hs --- a/src/Keiro/Wake.hs +++ b/src/Keiro/Wake.hs @@ -1,48 +1,47 @@ -{- | A wake signal for keiro's poll-loop workers (EP-50, LISTEN/NOTIFY push delivery). - -keiro's background workers — the workflow resume worker, the durable-timer worker, -the outbox publisher — make progress by polling: run one "claim, process, commit" -pass, then sleep a fixed interval. That fixed sleep is also the worst-case latency -(the resume worker's default is a full second). This module lets a worker instead -/wait to be woken/: it blocks until either a relevant append notification arrives — -meaning "something was appended, go look" — or a bounded fallback timeout elapses. - -== Where the wake comes from (no new connection) - -The kiroku event store already fires a Postgres @NOTIFY@ on channel @\.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 (..), +-- | 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, +import Control.Concurrent.STM + ( TChan, atomically, check, dupTChan, @@ -51,62 +50,57 @@ readTChan, readTVar, registerDelay, - ) + ) import Kiroku.Store.Connection (KirokuStore (..)) import Kiroku.Store.Notification (Notifier (..)) -{- | Why a 'waitForWake' returned: a notification arrived, or the fallback timeout -elapsed. Both mean "run another pass"; the distinction is available for telemetry. --} +-- | Why a 'waitForWake' returned: a notification arrived, or the fallback timeout +-- elapsed. Both mean "run another pass"; the distinction is available for telemetry. data WakeReason = WokenByNotify | WokenByTimeout - deriving stock (Eq, Show) + deriving stock (Eq, Show) -{- | A source of "something was appended, go look" wake-ups, layered over a bounded -fallback timeout so a missed notification never stalls progress. --} +-- | A source of "something was appended, go look" wake-ups, layered over a bounded +-- fallback timeout so a missed notification never stalls progress. newtype WakeSignal = WakeSignal - { waitForWake :: Int -> IO WakeReason - {- ^ Block until a notification arrives OR the given fallback timeout - (microseconds) elapses, whichever is first. Returns which happened. - -} - } + { -- | Block until a notification arrives OR the given fallback timeout + -- (microseconds) elapses, whichever is first. Returns which happened. + waitForWake :: Int -> IO WakeReason + } -{- | Build a 'WakeSignal' from a running kiroku store's notifier. Duplicates the -store's broadcast tick channel ('dupTChan') __once__ here, so this consumer has its -own cursor and never steals another consumer's ticks, and so ticks arriving between -waits queue in the duplicated channel rather than being lost. Opens __no__ new -database connection: it rides the single dedicated listener connection the store -already holds. --} +-- | Build a 'WakeSignal' from a running kiroku store's notifier. Duplicates the +-- store's broadcast tick channel ('dupTChan') __once__ here, so this consumer has its +-- own cursor and never steals another consumer's ticks, and so ticks arriving between +-- waits queue in the duplicated channel rather than being lost. Opens __no__ new +-- database connection: it rides the single dedicated listener connection the store +-- already holds. wakeSignalFromStore :: KirokuStore -> IO WakeSignal wakeSignalFromStore store = do - myChan <- atomically (dupTChan (tickChan (notifier store))) - pure (WakeSignal (waitOn myChan)) + myChan <- atomically (dupTChan (tickChan (notifier store))) + pure (WakeSignal (waitOn myChan)) where waitOn :: TChan () -> Int -> IO WakeReason waitOn myChan timeoutMicros = do - timer <- registerDelay timeoutMicros - atomically $ - ( do - -- A tick is queued: collapse any backlog so one wait returns once per - -- "there is new work" episode (the worker re-queries durably anyway). - _ <- readTChan myChan - drain myChan - pure WokenByNotify - ) - `orElse` (readTVar timer >>= check >> pure WokenByTimeout) + timer <- registerDelay timeoutMicros + atomically $ + ( do + -- A tick is queued: collapse any backlog so one wait returns once per + -- "there is new work" episode (the worker re-queries durably anyway). + _ <- readTChan myChan + drain myChan + pure WokenByNotify + ) + `orElse` (readTVar timer >>= check >> pure WokenByTimeout) drain ch = do - empty <- isEmptyTChan ch - if empty then pure () else readTChan ch >> drain ch + empty <- isEmptyTChan ch + if empty then pure () else readTChan ch >> drain ch -{- | A 'WakeSignal' that never fires a notification — every wait elapses the fallback -timeout. Used to simulate "all NOTIFYs dropped" (proving push is an optimization over -the durable poll) and to give a fixed-poll worker an unchanged cadence under the same -push-aware driver. --} +-- | A 'WakeSignal' that never fires a notification — every wait elapses the fallback +-- timeout. Used to simulate "all NOTIFYs dropped" (proving push is an optimization over +-- the durable poll) and to give a fixed-poll worker an unchanged cadence under the same +-- push-aware driver. neverWake :: WakeSignal neverWake = WakeSignal $ \timeoutMicros -> do - timer <- registerDelay timeoutMicros - atomically (readTVar timer >>= check) - pure WokenByTimeout + timer <- registerDelay timeoutMicros + atomically (readTVar timer >>= check) + pure WokenByTimeout diff --git a/src/Keiro/Workflow.hs b/src/Keiro/Workflow.hs --- a/src/Keiro/Workflow.hs +++ b/src/Keiro/Workflow.hs @@ -1,1087 +1,1051 @@ {-# LANGUAGE TypeFamilies #-} -{- | The durable workflow runtime: the @Workflow@ effect, named-step -journaling, replay, and suspension. - -== What this gives you - -Write a long-running process as an ordinary @effectful@ computation and run -it with 'runWorkflow'. Each @'step' name action@ either runs @action@ and -records ("journals") its result, or — on a replay after a crash — returns the -previously recorded result /without/ re-running the side effect. The journal -is a kiroku stream named @wf:\-\@ ('workflowStreamName'); there is -no separate history table. Because a workflow can pause (waiting for a timer, -an external signal, or a child), 'runWorkflow' returns a 'WorkflowOutcome' -('Completed' or 'Suspended'). - -Step side effects are at-least-once across process crashes. If the process -crashes after @action@ runs but before the journal append commits, a later -resume has no record of that step and runs @action@ again. Step bodies that call -external systems must therefore be idempotent, typically by deriving an -idempotency key from the workflow identity and step name and passing it to the -external system. - -Replay is keyed by step name, not by source position or code identity. Renaming -a step intentionally orphans the old journal entry and runs the renamed step as -new work; changing the meaning of a step while keeping the same name is the -author's responsibility. Use 'patch' for cross-cutting workflow-body changes -that need an explicit old/new branch. - -== Contract recap for downstream plans (the v2 MasterPlan) - -* The authoring surface is the @Workflow@ effect with 'step', 'awaitStep', - 'currentWorkflow', and 'freshOrdinal'. Add new primitives (sleep, - awakeable, child) as functions that go /through/ this effect so a single - import stays the workflow surface. -* 'awaitStep' is the suspension primitive every wake source builds on: it - returns a journaled result if present, otherwise runs an idempotent - /arming/ action once and suspends the run. The arming action MUST be - idempotent — a suspended-then-resumed workflow re-enters 'awaitStep' from - the top on every resume until the result is journaled, so it re-runs @arm@ - each time (e.g. schedule a timer with a deterministic id so repeats - collapse to a no-op). -* A wake source's external completion path (a timer firing, - @signalAwakeable@, a child finishing) calls 'appendJournalEntry' (or - 'appendJournalEntryReturningId') with a 'StepRecorded' whose @stepName@ is - the awaited step name; the next 'runWorkflow' then takes the 'awaitStep' - hit path and proceeds. -* The journal codec ('workflowJournalCodec') and the reserved step-name - prefixes ('sleepStepPrefix' = @"sleep:"@, 'awakeableStepPrefix' = @"awk:"@, - 'childStepPrefix' = @"child:"@) are integration contracts: suspensions are - journaled as ordinary 'StepRecorded' events with these prefixes, never as - new event types, so the replay loop stays uniform. -* Per-run options live in one record, 'WorkflowRunOptions' (EP-41 adds a - snapshot policy, EP-44 adds metrics/tracer); 'runWorkflowWith' is the - single canonical entry EP-42's resume worker re-invokes through. -* The derived @keiro_workflows@ instance row is maintained by journal append - transactions. Terminal markers ('WorkflowCompleted', 'WorkflowCancelled', - 'WorkflowFailed') freeze the instance as completed/cancelled/failed, and the - resume worker uses its attempt/lease fields for crash recovery. -* Discovery (EP-42) is 'findUnfinishedWorkflowIds' plus 'completedStepName'; - it needs no kiroku prefix subscription. - -> __Build gotcha__ (EP-38's migration adds @keiro_workflow_steps@): adding a -> new @.sql@ file under @keiro-migrations/sql-migrations/@ does not trigger -> recompilation of @Keiro.Migrations@ (cabal says "Up to date" even with -> @-fforce-recomp@, because @embedDir@ is a Template Haskell directory read -> GHC's recompilation checker does not track per-file). After adding a -> migration, edit a comment in @keiro-migrations/src/Keiro/Migrations.hs@ or -> run @cabal clean@ before building. --} -module Keiro.Workflow ( - -- * The effect and authoring surface - Workflow, - step, - awaitStep, - currentWorkflow, - currentRunGeneration, - freshOrdinal, - continueAsNew, - restoreSeed, - patch, - - -- * Running a workflow - runWorkflow, - runWorkflowWith, - WorkflowRunOptions (..), - LeaseHeartbeat (..), - defaultWorkflowRunOptions, - - -- * Journal append helpers (used by wake-source plans) - JournalAppendOutcome (..), - prepareJournalAppend, - appendJournalEntry, - appendJournalEntryReturningId, - deterministicJournalId, - - -- * Errors thrown by the runtime - WorkflowError (..), - WorkflowLeaseLost (..), - - -- * Re-exported core contracts - module Keiro.Workflow.Types, - WorkflowStepRow (..), - recordStepTx, - loadStepIndex, - stepExists, - currentGeneration, - findUnfinishedWorkflowIds, - setWorkflowWakeAfterTx, - clearWorkflowWakeAfterTx, -) -where - -import Control.Exception (Exception) -import Data.Aeson qualified as Aeson -import Data.IORef ( - IORef, - atomicModifyIORef', - newIORef, - readIORef, - ) -import Data.Int (Int32) -import Data.Map.Strict (Map) -import Data.Map.Strict qualified as Map -import Data.Set (Set) -import Data.Set qualified as Set -import Data.Text qualified as Text -import Data.Time (NominalDiffTime) -import Data.UUID.V5 qualified as UUID.V5 -import Effectful (Dispatch (..), DispatchOf, Eff, Effect, IOE, (:>)) -import Effectful.Dispatch.Dynamic (EffectHandler, interpret, localSeqUnlift, send) -import Effectful.Error.Static (Error, tryError) -import Effectful.Exception (bracket_, catch, throwIO) -import Keiro.Codec (decodeRecorded, encodeForAppendWithMetadata) -import Keiro.EventStream (SnapshotPolicy (..), Terminality (..)) -import Keiro.Prelude -import Keiro.Snapshot (SnapshotMissReason (..)) -import Keiro.Snapshot.Policy (shouldSnapshot) -import Keiro.Telemetry ( - KeiroMetrics, - Tracer, - recordSnapshotDecodeFailures, - recordSnapshotReadHits, - recordSnapshotReadMisses, - recordSnapshotWriteFailures, - recordWorkflowActive, - recordWorkflowJournalLength, - recordWorkflowStepExecuted, - recordWorkflowStepReplayed, - withWorkflowSpan, - ) -import Keiro.Workflow.Instance ( - WorkflowStatus (..), - markInstanceSuspended, - renewInstanceLease, - upsertInstanceTx, - ) -import Keiro.Workflow.Schema (WorkflowStepRow (..), clearWorkflowWakeAfterTx, currentGeneration, findUnfinishedWorkflowIds, loadStepIndex, lockWorkflowStepTx, lookupStepResult, lookupStepResultTx, recordStepTx, setWorkflowWakeAfterTx, stepExists) -import Keiro.Workflow.Snapshot (lookupWorkflowSnapshot, writeWorkflowSnapshot) -import Keiro.Workflow.Types -import Kiroku.Store.Effect (Store) -import Kiroku.Store.Error (StoreError) -import Kiroku.Store.Read (readStreamForwardStream) -import Kiroku.Store.Transaction (AppendConflict, appendToStreamTx, prepareEventsIO, runTransaction) -import Kiroku.Store.Types (AppendResult (..), EventData, EventId (..), ExpectedVersion (..), StreamId, StreamVersion (..)) -import Streamly.Data.Fold qualified as Fold -import Streamly.Data.Stream qualified as Streamly -import System.IO.Unsafe (unsafePerformIO) -import "hasql-transaction" Hasql.Transaction qualified as Tx - --- --------------------------------------------------------------------------- --- The effect --- --------------------------------------------------------------------------- - -{- | The durable workflow effect. Its operations are interpreted by -'runWorkflow' / 'runWorkflowWith', which journal and replay them. --} -data Workflow :: Effect where - {- | Run a side-effecting action under a name, journaling its result; on - replay, return the recorded result without re-running the action. - -} - Step :: (Aeson.ToJSON a, Aeson.FromJSON a) => StepName -> m a -> Workflow m a - {- | Return the awaited step's journaled result, or run the (idempotent) - arming action once and suspend the run. - -} - Await :: (Aeson.FromJSON a) => StepName -> m () -> Workflow m a - -- | The running workflow's identity (for keying wake sources). - CurrentWorkflow :: Workflow m (WorkflowName, WorkflowId) - -- | The journal generation this run is operating on. - CurrentRunGeneration :: Workflow m Int - -- | A per-run, per-namespace counter for deterministic ordinal step names. - FreshOrdinal :: Text -> Workflow m Int - {- | EP-48: snapshot the carried seed, rotate onto a fresh journal generation, - and unwind this run; the next run/resume continues from the seed. Never - returns to the caller within this run (result type is fully polymorphic). - -} - ContinueAsNew :: (Aeson.ToJSON s) => s -> Workflow m a - {- | EP-49: decide and journal a cross-cutting branch — returns the stable - 'Bool' branch decision for the given patch. Fresh instances get 'True' - (new branch); instances already in flight when the patch shipped get - 'False' (old branch). The decision is journaled on first encounter and - replayed verbatim thereafter. - -} - Patch :: PatchId -> Workflow m Bool - -type instance DispatchOf Workflow = Dynamic - -{- | Run @action@ under @name@, journaling its encoded result. On a replay where -@name@ is already journaled, the recorded result is returned and @action@ is -not run. If the process crashed after @action@ ran but before the journal -commit, the action runs again on resume: workflow step side effects are -at-least-once at the step boundary. - -The returned value is always the JSON round-trip of the recorded result, -including on the first run. A lossy or rejecting @ToJSON@\/@FromJSON@ pair is -therefore observed immediately rather than only after a crash and replay. - -Requires @'Aeson.ToJSON' a@ (to journal the result) and @'Aeson.FromJSON' a@ -(to decode it on replay). --} -step :: (Workflow :> es, Aeson.ToJSON a, Aeson.FromJSON a) => StepName -> Eff es a -> Eff es a -step name action = send (Step name action) - -{- | Look up @name@ in the journal. If a wake source has already recorded its -completion (a 'StepRecorded' whose @stepName@ is @name@, carrying the -resolved result), decode and return it. Otherwise run @arm@ exactly once -(the wake source's idempotent job — schedule a timer, register an awakeable, -spawn a child) and __suspend__ this run, so 'runWorkflow' returns 'Suspended'. - -@arm@ must be idempotent: every resume re-runs it until the result is -journaled. --} -awaitStep :: (Workflow :> es, Aeson.FromJSON a) => StepName -> Eff es () -> Eff es a -awaitStep name arm = send (Await name arm) - --- | The identity of the workflow currently running. -currentWorkflow :: (Workflow :> es) => Eff es (WorkflowName, WorkflowId) -currentWorkflow = send CurrentWorkflow - -{- | The journal generation this run is operating on. Wake sources include it -in their durable identities so a generation opened by 'continueAsNew' never -collides with prior-generation rows. --} -currentRunGeneration :: (Workflow :> es) => Eff es Int -currentRunGeneration = send CurrentRunGeneration - -{- | A per-run, per-namespace counter (starting at 0). Used by convenience -forms of wake sources (e.g. @sleep@ → @"sleep:0"@) to derive a deterministic, -replay-stable ordinal name. Note: ordinal names are only stable if the order -of @awaitStep@-style calls does not change across deploys; the named forms -are the stable primitives. --} -freshOrdinal :: (Workflow :> es) => Text -> Eff es Int -freshOrdinal namespace = send (FreshOrdinal namespace) - -{- | Continue this workflow /as new/ (EP-48): snapshot the carried @seed@ onto a -fresh journal generation, journal a terminal rotation marker on the current -generation, and unwind this run. The next run or resume of the same logical -@('WorkflowName', 'WorkflowId')@ starts against the fresh generation, hydrated -from the seed, with an empty (bounded) journal. - -This is how a workflow that runs an /unbounded/ number of steps — a poller, a -per-day rolling process — keeps its per-generation journal bounded so replay -and hydration stay fast forever. The result type is fully polymorphic (@a@) -because control never returns to the caller within /this/ run: the rotated -continuation runs in the next run/resume. Read the carried seed back at the top -of the workflow body with 'restoreSeed'. --} -continueAsNew :: (Workflow :> es, Aeson.ToJSON s) => s -> Eff es a -continueAsNew seed = send (ContinueAsNew seed) - -{- | Restore the seed carried by the previous generation's 'continueAsNew', or -return @def@ on the first generation (EP-48). Implemented as an ordinary -journaled @step@ under the reserved 'continueSeedStepName': on a generation that -was rotated into, the seed step was journaled (and snapshotted) by the rotation, -so this @step@ hits it and returns the carried value without re-running; on the -very first generation it misses and records @def@. Call it once at the top of a -workflow body that uses 'continueAsNew'. --} -restoreSeed :: (Workflow :> es, Aeson.ToJSON s, Aeson.FromJSON s) => s -> Eff es s -restoreSeed def = step (StepName continueSeedStepName) (pure def) - -{- | Decide a cross-cutting branch for an in-flight-vs-fresh code change, and -journal the decision so every later replay observes the same branch (EP-49). - -@patch (PatchId "fraud-check-v2")@ returns 'True' only when that id was present -in 'activePatches' when this workflow generation first started. The generation -records its active set under 'patchSetStepName' exactly once; on the first -encounter each individual patch decision is journaled under @patch:\@, -and every replay returns the recorded 'Bool'. Add a patch id to 'activePatches' -in the deploy that introduces the corresponding 'patch' call; remove it only -after deleting that call from the workflow body. - -This is an /escape hatch/ for changes that cross-cut multiple steps. For the -common case — one step changed — do __not__ use 'patch': rename the step's -'StepName' instead. A renamed step has no journaled history under its new name, -so its action runs fresh on the next replay, which is exactly the right -behaviour for a single-step change. Reach for 'patch' only when an in-flight -instance would be left incoherent by the new code (e.g. the change adds, removes, -or reorders steps, or changes the meaning of an already-journaled step result). --} -patch :: (Workflow :> es) => PatchId -> Eff es Bool -patch pid = send (Patch pid) - --- --------------------------------------------------------------------------- --- Per-run options --- --------------------------------------------------------------------------- - -{- | Lease renewal coordinates for a resume-worker-owned workflow run. - -The runtime renews this lease immediately before each fresh step action and -unresolved await arm. Direct 'runWorkflow' calls leave it 'Nothing'. --} -data LeaseHeartbeat = LeaseHeartbeat - { owner :: !Text - , ttl :: !NominalDiffTime - } - deriving stock (Generic, Eq, Show) - -{- | Options for a single workflow run. This is the canonical home for -per-run options across the v2 initiative — EP-41 adds the snapshot policy, -EP-44 adds metrics/tracer fields, all additive. Extend it additively; never -break the field set EP-38/EP-41 established. --} -data WorkflowRunOptions = WorkflowRunOptions - { snapshotPolicy :: !(SnapshotPolicy WorkflowState) - {- ^ When to persist a snapshot of the accumulated step-result map after a - step append (and at completion, for 'OnTerminal'). Default 'Never' - (EP-38 behaviour: every run/resume does a full version-0 replay). - -} - , pageSize :: !Int32 - -- ^ Page size for the journal pre-load read. - , metrics :: !(Maybe KeiroMetrics) - {- ^ EP-44: when 'Just', the runtime records the @keiro.workflow.*@ instruments - (steps executed/replayed, active count, journal length). 'Nothing' is the - no-op default, so a run with 'defaultWorkflowRunOptions' records nothing. - -} - , tracer :: !(Maybe Tracer) - {- ^ EP-44: when 'Just', the runtime opens a @workflow \@ 'Internal' span - around the run. 'Nothing' runs the body unwrapped. - -} - , activePatches :: !(Set PatchId) - {- ^ Patch ids currently active in this deployed workflow code. A fresh - workflow generation records this set once under 'patchSetStepName', and - each 'patch' call returns 'True' iff its id was in that recorded set. - -} - , leaseHeartbeat :: !(Maybe LeaseHeartbeat) - {- ^ Resume-worker lease coordinates. When present, fresh workflow - boundaries renew the lease and throw 'WorkflowLeaseLost' if another owner - has taken it. 'Nothing' keeps direct runs free of lease traffic. - -} - } - deriving stock (Generic) - -{- | Sensible defaults: no snapshotting, a journal pre-load page size of 100, -and no telemetry (metrics/tracer 'Nothing'). A default-options run replays -and behaves exactly as EP-38 did. --} -defaultWorkflowRunOptions :: WorkflowRunOptions -defaultWorkflowRunOptions = - WorkflowRunOptions - { snapshotPolicy = Never - , pageSize = 100 - , metrics = Nothing - , tracer = Nothing - , activePatches = Set.empty - , leaseHeartbeat = Nothing - } - --- --------------------------------------------------------------------------- --- Errors and the suspension sentinel --- --------------------------------------------------------------------------- - -{- | Errors the workflow runtime raises (via 'throwIO', so they surface -through the surrounding store/IO error channel). --} -data WorkflowError - = {- | A journaled step result could not be decoded into the type the - replaying @step@/@awaitStep@ expects (step name, decode message). The - result type changed incompatibly — a programmer error. - -} - WorkflowStepDecodeError !Text !Text - | -- | A journal event could not be decoded during pre-load. - WorkflowJournalDecodeError !Text - | -- | A journal event could not be encoded for append. - WorkflowJournalEncodeError !Text - | -- | Appending a journal entry failed for a non-conflict reason. - WorkflowJournalAppendError !Text - deriving stock (Eq, Show) - -instance Exception WorkflowError - -{- | The resume worker no longer owns the workflow instance lease. - -Thrown before a fresh step action or unresolved await arm, so the run stops -before performing further side effects. Resume workers classify this as a -lease skip rather than a workflow crash. --} -data WorkflowLeaseLost = WorkflowLeaseLost - deriving stock (Eq, Show) - -instance Exception WorkflowLeaseLost - --- | Internal sentinel thrown to unwind a suspended run up to 'runWorkflowWith'. -data WorkflowSuspend = WorkflowSuspend - deriving stock (Show) - -instance Exception WorkflowSuspend - --- | Internal sentinel thrown when a cancellation marker appears mid-run. -data WorkflowCancelPending = WorkflowCancelPending - deriving stock (Show) - -instance Exception WorkflowCancelPending - -{- | Internal sentinel thrown by the 'ContinueAsNew' handler to unwind a -rotating run up to 'runWorkflowWith' (EP-48), carrying the JSON-encoded seed for -the next generation. Mirrors 'WorkflowSuspend': a non-returning unwind the run -entry point catches and turns into an outcome ('ContinuedAsNew'). --} -newtype WorkflowRotate = WorkflowRotate Aeson.Value - deriving stock (Show) - -instance Exception WorkflowRotate - --- --------------------------------------------------------------------------- --- Running --- --------------------------------------------------------------------------- - -{- | Process-wide count of workflow runs currently in flight, backing the -@keiro.workflow.active@ gauge (EP-44). 'runWorkflowWith' brackets each run with -@+1@/@-1@ and samples the gauge on both edges, so the exported last-value -reflects the true live count whether a run is mid-flight or finished. A -process-global 'IORef' is the lightest faithful implementation (the gauge is a -last-value-wins level, not a per-run delta), mirroring how the other keiro -backlog/level gauges are recorded with a value the runtime already holds. --} -{-# NOINLINE activeCountRef #-} -activeCountRef :: IORef Int64 -activeCountRef = unsafePerformIO (newIORef 0) - -{- | Run a workflow computation, journaling each 'step' and replaying any -already-journaled steps. Returns 'Completed' when the computation finishes -(a 'WorkflowCompleted' marker is journaled) or 'Suspended' when it pauses at -an unresolved 'awaitStep'. - -Equivalent to @'runWorkflowWith' 'defaultWorkflowRunOptions'@. --} -runWorkflow :: - (IOE :> es, Store :> es, Error StoreError :> es) => - WorkflowName -> - WorkflowId -> - Eff (Workflow : es) a -> - Eff es (WorkflowOutcome a) -runWorkflow = runWorkflowWith defaultWorkflowRunOptions - -{- | 'runWorkflow' with explicit 'WorkflowRunOptions'. This is the single -canonical run entry point; EP-42's resume worker re-invokes through it so -resumed runs honor the same options. - -If the workflow's journal already carries a 'WorkflowCancelled' marker (a child -cancelled by its parent, EP-43), the run short-circuits immediately and returns -'Cancelled' without executing any step. The handler also re-checks that marker -on step/await/patch miss paths and after a fresh step action returns, so a -mid-run cancellation stops at the next workflow boundary. A cancellation that -lands after the check but before/during the user action may still let that one -action run; durable workflow steps remain at-least-once at boundaries. If the -journal carries a 'WorkflowFailed' marker, the run likewise short-circuits to -'Failed'. To /propagate/ a finished child's result to its parent, drive the -child through 'Keiro.Workflow.Child.runChildWorkflow' rather than this function -directly. --} -runWorkflowWith :: - forall a es. - (IOE :> es, Store :> es, Error StoreError :> es) => - WorkflowRunOptions -> - WorkflowName -> - WorkflowId -> - Eff (Workflow : es) a -> - Eff es (WorkflowOutcome a) -runWorkflowWith options name wid action = do - -- EP-48: resolve the CURRENT (highest) generation once per run and operate - -- only on it. A never-rotating workflow stays at generation 0, so naming, - -- load, and append are byte-for-byte as before. A rotated workflow resolves - -- to its newest generation, so discovery/resume transparently continue there. - gen <- currentGeneration name wid - -- Cancellation short-circuit (EP-43): a workflow whose journal carries a - -- WorkflowCancelled marker makes no further progress. The index row for that - -- marker is keyed under 'cancelledStepName' on the current generation, so a - -- single existence check is enough and we never run the user action. - cancelled <- stepExists name wid gen cancelledStepName - failed <- stepExists name wid gen failedStepName - case (cancelled, failed) of - (True, _) -> pure Cancelled - (_, True) -> pure Failed - _ -> runActive gen - where - -- EP-44 telemetry handles, pulled from the run options once. Both default - -- to 'Nothing' (see 'defaultWorkflowRunOptions'), so a default-options run - -- records nothing and opens no span — the no-op idiom holds end to end. - mMetrics = options ^. #metrics - mTracer = options ^. #tracer - runActive :: Int -> Eff es (WorkflowOutcome a) - runActive gen = - -- EP-44: maintain the process-wide live-run count and sample the - -- @keiro.workflow.active@ gauge on both entry and exit, and open the - -- whole-run @workflow \@ span (step 'Nothing'). The body is - -- unchanged from EP-41 except for the journal-length recording below. - bracket_ - (liftIO (atomicModifyIORef' activeCountRef (\n -> (n + 1, ()))) >> sampleActive) - (liftIO (atomicModifyIORef' activeCountRef (\n -> (n - 1, ()))) >> sampleActive) - (withWorkflowSpan mTracer name wid Nothing (\_sp -> interpreted)) - where - sampleActive = liftIO (readIORef activeCountRef) >>= recordWorkflowActive mMetrics - interpreted = do - initial <- loadJournal options name wid gen - initial' <- recordPatchSetIfFresh gen initial - journalRef <- liftIO (newIORef initial') - ordinalRef <- liftIO (newIORef Map.empty) - let runHandler = interpret (handler gen journalRef ordinalRef) action - outcome <- - (Completed <$> runHandler) - `catch` (\WorkflowSuspend -> pure Suspended) - `catch` (\WorkflowCancelPending -> pure Cancelled) - `catch` ( \(WorkflowRotate seedJson) -> - rotateGeneration - mMetrics - (options ^. #activePatches) - name - wid - gen - seedJson - ) - case outcome of - Completed result -> do - now <- liftIO getCurrentTime - finalMap <- liftIO (readIORef journalRef) - -- Idempotent: only appends (and so only snapshots) when the completion - -- marker is not already journaled. On a replay of an already-completed - -- workflow this is 'Nothing' and no terminal snapshot is taken (one was - -- already taken on the original completing run, if the policy fired). - mAppend <- appendCompletion name wid gen now - for_ mAppend $ \appendResult -> - when - ( shouldSnapshot - (options ^. #snapshotPolicy) - Terminal - finalMap - (appendResult ^. #streamVersion) - ) - (writeWorkflowSnapshotAdvisory mMetrics (appendResult ^. #streamId) (appendResult ^. #streamVersion) finalMap) - -- EP-44: record one @keiro.workflow.journal.length@ observation per - -- completing run (the 'Completed' path only, never 'Suspended'), - -- including a replay that completes again. Length is the recorded - -- step map plus the WorkflowCompleted marker. - recordWorkflowJournalLength mMetrics (fromIntegral (Map.size finalMap + 1)) - pure (Completed result) - Suspended -> markInstanceSuspended name wid >> pure Suspended - Cancelled -> pure Cancelled - Failed -> pure Failed - -- EP-48: the run unwound via 'WorkflowRotate'; 'rotateGeneration' - -- already journaled the seed step on the next generation and the - -- rotation marker on this one, so there is nothing more to do here. - ContinuedAsNew -> pure ContinuedAsNew - -- Generation 0 has no rotation moment at which to record the patch set, - -- so it retains the fresh-journal path. Rotated generations receive the - -- set atomically with their seed in 'rotateGeneration'; this fallback - -- also keeps generations produced by a pre-change worker compatible. - recordPatchSetIfFresh runGen initial = do - let patches = options ^. #activePatches - freshStart = Map.keysSet initial `Set.isSubsetOf` Set.singleton continueSeedStepName - if freshStart && not (Set.null patches) - then do - let encoded = Aeson.toJSON (map unPatchId (Set.toList patches)) - now <- liftIO getCurrentTime - appendJournal name wid runGen (StepRecorded patchSetStepName encoded now) >>= \case - JournalAppended{} -> pure (Map.insert patchSetStepName encoded initial) - JournalAlreadyPresent stored -> pure (Map.insert patchSetStepName stored initial) - JournalAppendConflict err -> throwIO (WorkflowJournalAppendError (Text.pack (show err))) - else pure initial - handler :: - Int -> - IORef (Map Text Aeson.Value) -> - IORef (Map Text Int) -> - EffectHandler Workflow es - handler gen journalRef ordinalRef env operation = case operation of - Step (StepName key) act -> do - journal <- liftIO (readIORef journalRef) - case Map.lookup key journal of - Just stored -> do - -- Hit: the step is already journaled, so its recorded result is - -- returned without re-running @act@ — a replay. - recordWorkflowStepReplayed mMetrics 1 - decodeStored key stored - Nothing -> do - renewLease - checkCancellationPending name wid gen - a <- localSeqUnlift env (\unlift -> unlift act) - checkCancellationPending name wid gen - let encoded = Aeson.toJSON a - now <- liftIO getCurrentTime - appendOutcome <- appendJournal name wid gen (StepRecorded key encoded now) - case appendOutcome of - JournalAppended appendResult -> do - -- Miss: @act@ ran and was journaled — a fresh execution. - recordWorkflowStepExecuted mMetrics 1 - newMap <- - liftIO - ( atomicModifyIORef' journalRef $ \m -> - let m' = Map.insert key encoded m in (m', m') - ) - -- Evaluate the snapshot policy on the post-append map and version; - -- a step is never the terminal marker, hence @False@. - when - ( shouldSnapshot - (options ^. #snapshotPolicy) - NotTerminal - newMap - (appendResult ^. #streamVersion) - ) - (writeWorkflowSnapshotAdvisory mMetrics (appendResult ^. #streamId) (appendResult ^. #streamVersion) newMap) - decodeStored key encoded - JournalAlreadyPresent stored -> do - liftIO - ( atomicModifyIORef' journalRef $ \m -> - (Map.insert key stored m, ()) - ) - decodeStored key stored - JournalAppendConflict err -> - throwIO (WorkflowJournalAppendError (Text.pack (show err))) - Await (StepName key) arm -> do - journal <- liftIO (readIORef journalRef) - case Map.lookup key journal of - Just stored -> do - -- An awaitStep hit means the wake source already resolved this step; - -- the recorded result is returned without arming — a replay. An - -- awaitStep miss arms and suspends: no user @action@ ran, so it is - -- not a step execution and records nothing here. - recordWorkflowStepReplayed mMetrics 1 - decodeStored key stored - Nothing -> - -- The in-memory map can omit a wake completion journaled - -- while a snapshotting run was mid-flight. The step index - -- is written transactionally with every append, so consult - -- it before arming and suspending. - lookupStepResult name wid gen key >>= \case - Just stored -> do - liftIO - ( atomicModifyIORef' journalRef $ \m -> - (Map.insert key stored m, ()) - ) - recordWorkflowStepReplayed mMetrics 1 - decodeStored key stored - Nothing -> do - renewLease - checkCancellationPending name wid gen - localSeqUnlift env (\unlift -> unlift arm) - throwIO WorkflowSuspend - CurrentWorkflow -> pure (name, wid) - CurrentRunGeneration -> pure gen - FreshOrdinal namespace -> - liftIO . atomicModifyIORef' ordinalRef $ \counters -> - let n = Map.findWithDefault 0 namespace counters - in (Map.insert namespace (n + 1) counters, n) - -- EP-48: encode the carried seed and throw the rotation sentinel, which - -- 'runWorkflowWith' catches and turns into 'rotateGeneration'. Never - -- returns to the caller within this run (result type is polymorphic). - ContinueAsNew seed -> throwIO (WorkflowRotate (Aeson.toJSON seed)) - -- EP-49: decide and journal a cross-cutting branch. Mirrors the 'Step' - -- hit/miss shape, but the miss path computes the decision from the - -- patch set recorded when this workflow generation first started. - Patch pid -> do - let key = patchStepName pid - journal <- liftIO (readIORef journalRef) - case Map.lookup key journal of - Just stored -> - -- Hit: the decision was made on an earlier run; replay it verbatim. - decodeStored key stored - Nothing -> do - checkCancellationPending name wid gen - recordedSet <- case Map.lookup patchSetStepName journal of - Nothing -> pure [] - Just stored -> decodeStored patchSetStepName stored - let decision = unPatchId pid `elem` (recordedSet :: [Text]) - encoded = Aeson.toJSON decision - now <- liftIO getCurrentTime - appendOutcome <- appendJournal name wid gen (StepRecorded key encoded now) - case appendOutcome of - JournalAppended{} -> do - liftIO - ( atomicModifyIORef' journalRef $ \m -> - (Map.insert key encoded m, ()) - ) - pure decision - JournalAlreadyPresent stored -> do - liftIO - ( atomicModifyIORef' journalRef $ \m -> - (Map.insert key stored m, ()) - ) - decodeStored key stored - JournalAppendConflict err -> - throwIO (WorkflowJournalAppendError (Text.pack (show err))) - where - renewLease = - for_ (options ^. #leaseHeartbeat) $ \heartbeat -> do - renewed <- - renewInstanceLease - (heartbeat ^. #owner) - (heartbeat ^. #ttl) - name - wid - unless renewed (throwIO WorkflowLeaseLost) - --- | Decode a stored journal result into the type the caller expects. -decodeStored :: (Aeson.FromJSON a) => Text -> Aeson.Value -> Eff es a -decodeStored key stored = case Aeson.fromJSON stored of - Aeson.Success a -> pure a - Aeson.Error message -> throwIO (WorkflowStepDecodeError key (Text.pack message)) - -checkCancellationPending :: (Store :> es) => WorkflowName -> WorkflowId -> Int -> Eff es () -checkCancellationPending name wid gen = do - cancelled <- stepExists name wid gen cancelledStepName - when cancelled (throwIO WorkflowCancelPending) - -{- | Pre-load a workflow's journal stream into a @step name -> result@ map. - -If a compatible snapshot exists ('loadWorkflowSnapshot'), seed the map from it -and read only the journal events /after/ the snapshot's version ("tail -replay"). The reconstructed map is the journal state as the snapshotting run -saw it. A wake completion journaled concurrently with that run can fall at or -before the snapshot version yet be absent from the seed, so the map may -under-approximate the journal. The @Await@ handler compensates by consulting -the authoritative @keiro_workflow_steps@ index on a map miss; that index is -written transactionally with every journal append. - -A missing, mismatched, or undecodable snapshot is recorded as a miss (and, for -undecodable bytes, a decode failure) before the read falls back to a full -replay from version 0. -'WorkflowCompleted' contributes nothing to the map. --} -loadJournal :: - (IOE :> es, Store :> es) => - WorkflowRunOptions -> - WorkflowName -> - WorkflowId -> - Int -> - Eff es (Map Text Aeson.Value) -loadJournal options name wid gen = do - let journalName = workflowGenerationStreamName name wid gen - snapshot <- lookupWorkflowSnapshot journalName - (seedMap, fromVersion) <- case snapshot of - Right (m, v) -> do - recordSnapshotReadHits (options ^. #metrics) 1 - pure (m, v) - Left reason -> do - recordSnapshotReadMisses (options ^. #metrics) 1 - case reason of - SnapshotDecodeFailed _ -> recordSnapshotDecodeFailures (options ^. #metrics) 1 - _ -> pure () - pure (Map.empty, StreamVersion 0) - let - events = readStreamForwardStream journalName fromVersion (options ^. #pageSize) - Streamly.fold (Fold.foldlM' accumulate (pure seedMap)) events - where - accumulate journal recorded = - case decodeRecorded workflowJournalCodec recorded of - Right (StepRecorded key value _) -> pure (Map.insert key value journal) - Right (WorkflowCompleted _) -> pure journal - Right (WorkflowCancelled _) -> pure journal - Right (WorkflowFailed _ _) -> pure journal - Right (WorkflowContinuedAsNew _ _) -> pure journal -- a rotation marker carries no step result - Left err -> throwIO (WorkflowJournalDecodeError (Text.pack (show err))) - --- --------------------------------------------------------------------------- --- Journal append helpers --- --------------------------------------------------------------------------- - -data JournalAppendOutcome - = JournalAppended !AppendResult - | JournalAlreadyPresent !Aeson.Value - | JournalAppendConflict !AppendConflict - deriving stock (Eq, Show) - -prepareJournalAppend :: - (IOE :> es) => - WorkflowName -> - WorkflowId -> - Int -> - WorkflowJournalEvent -> - Eff es (Tx.Transaction JournalAppendOutcome) -prepareJournalAppend name wid gen event = do - let key = journalKey event - entryId = deterministicJournalId name wid gen key - requestedEntryId = case event of - -- Resurrection removes the derived failure-marker index row while - -- retaining append-only journal history. A later failure on the - -- same generation therefore needs a fresh UUIDv7; step locking and - -- the in-transaction index check still deduplicate concurrent - -- failure writers. - WorkflowFailed{} -> Nothing - _ -> Just entryId - row = journalRow name wid gen event - (status, mLastError) = instanceStatusForEvent event - journalName = workflowGenerationStreamName name wid gen - lockKey = - Text.intercalate - "/" - [unWorkflowId wid, unWorkflowName name, Text.pack (show gen), key] - base <- case encodeForAppendWithMetadata workflowJournalCodec Nothing event of - Right encoded -> pure encoded - Left err -> throwIO (WorkflowJournalEncodeError (Text.pack (show err))) - let entry = base & #eventId .~ requestedEntryId :: EventData - prepared <- prepareEventsIO [entry] - now <- liftIO getCurrentTime - pure $ do - lockWorkflowStepTx lockKey - lookupStepResultTx (unWorkflowId wid) (unWorkflowName name) gen key >>= \case - Just stored -> pure (JournalAlreadyPresent stored) - Nothing -> - appendToStreamTx journalName AnyVersion prepared now >>= \case - Left err -> pure (JournalAppendConflict err) - Right appendResult -> - JournalAppended appendResult - <$ recordStepTx row - <* upsertInstanceTx - (unWorkflowId wid) - (unWorkflowName name) - (fromIntegral gen) - status - mLastError - -appendJournal :: (IOE :> es, Store :> es) => WorkflowName -> WorkflowId -> Int -> WorkflowJournalEvent -> Eff es JournalAppendOutcome -appendJournal name wid gen event = - prepareJournalAppend name wid gen event >>= runTransaction - -{- | Append a journal event to a workflow's journal stream (and keep its -index row consistent), idempotently. If the entry already exists this is a -no-op returning the would-be event id. - -This is the integration helper a wake source's external-completion path uses -to record an awaited step's resolution. The append uses a deterministic event -id derived from @("keiro" : "workflow" : name : id : stepName)@ so concurrent -or retried writes collapse to one row. --} -appendJournalEntry :: (IOE :> es, Store :> es) => WorkflowName -> WorkflowId -> WorkflowJournalEvent -> Eff es () -appendJournalEntry name wid event = void (appendJournalEntryReturningId name wid event) - -{- | Like 'appendJournalEntry' but returns the (deterministic) 'EventId' of -the entry. EP-39's fired timer needs this for @markTimerFired@. --} -appendJournalEntryReturningId :: (IOE :> es, Store :> es) => WorkflowName -> WorkflowId -> WorkflowJournalEvent -> Eff es EventId -appendJournalEntryReturningId name wid event = do - -- EP-48: a wake source (timer fired, signalAwakeable, child completion) - -- resolves the awaited step on whichever generation the suspended run is - -- parked on — always the current (highest) one, since runs only ever operate - -- on the current generation. Resolve it here so the append and its - -- deterministic id are namespaced by that generation. - gen <- currentGeneration name wid - let key = journalKey event - entryId = deterministicJournalId name wid gen key - appendJournal name wid gen event >>= \case - JournalAppended{} -> pure entryId - JournalAlreadyPresent{} -> pure entryId - JournalAppendConflict err -> throwIO (WorkflowJournalAppendError (Text.pack (show err))) - -{- | Append a journal entry only if it is not already journaled, returning the -'AppendResult' of the fresh append (or 'Nothing' if it already existed). Used -on the completion path so a terminal ('OnTerminal') snapshot can be taken from -the completing run's 'AppendResult', while a replay of an already-completed -workflow is a no-op. --} -appendCompletion :: (IOE :> es, Store :> es) => WorkflowName -> WorkflowId -> Int -> UTCTime -> Eff es (Maybe AppendResult) -appendCompletion name wid gen now = do - appendJournal name wid gen (WorkflowCompleted now) >>= \case - JournalAppended appendResult -> pure (Just appendResult) - JournalAlreadyPresent{} -> pure Nothing - JournalAppendConflict err -> throwIO (WorkflowJournalAppendError (Text.pack (show err))) - -{- | Perform a continue-as-new rotation (EP-48): close generation @gen@ and open -generation @gen + 1@, seeded with @seedJson@ and the deployed patch set. Returns -'ContinuedAsNew'. - -The next generation's seed and non-empty patch set are appended in one -transaction before the old generation's rotation marker. The seed advances -@MAX(generation)@ — and therefore 'currentGeneration' — to @gen + 1@, while the -same commit makes patch decisions available before any asynchronous wake writer -can append to the new generation. After that commit, any re-run resolves the -current generation to @gen + 1@, hydrates from the seed and patch set, and never -re-enters generation @gen@. We then append the terminal -'WorkflowContinuedAsNew' marker on generation @gen@. Every append is guarded by -an existence check and uses a deterministic, generation-namespaced id, so the -whole rotation is idempotent. - -The seed carries state forward and the patch-set entry freezes code-evolution -decisions. We snapshot their map at the newest fresh append's version so the -next generation hydrates in O(1). The snapshot is advisory, so it is written -unconditionally on rotation regardless of the run's 'snapshotPolicy' — rotation -is exactly when a fresh snapshot earns its keep. --} -rotateGeneration :: - forall a es. - (IOE :> es, Store :> es, Error StoreError :> es) => - Maybe KeiroMetrics -> - Set PatchId -> - WorkflowName -> - WorkflowId -> - Int -> - Aeson.Value -> - Eff es (WorkflowOutcome a) -rotateGeneration mMetrics patches name wid gen seedJson = do - let nextGen = gen + 1 - encodedPatches = Aeson.toJSON (map unPatchId (Set.toList patches)) - patchEvent = - StepRecorded patchSetStepName encodedPatches - now <- liftIO getCurrentTime - seedTx <- - prepareJournalAppend - name - wid - nextGen - (StepRecorded continueSeedStepName seedJson now) - patchTx <- - if Set.null patches - then pure Nothing - else - Just - <$> prepareJournalAppend - name - wid - nextGen - (patchEvent now) - -- 1. Seed and patch set on the NEXT generation in one transaction. A - -- conflict condemns the whole transaction before it returns its diagnostic - -- outcome, so no seed-without-patch intermediate state can commit. - (seedOutcome, patchOutcome) <- - runTransaction $ do - seedResult <- seedTx - condemnOnConflict seedResult - patchResult <- traverse id patchTx - traverse_ condemnOnConflict patchResult - pure (seedResult, patchResult) - throwOnConflict seedOutcome - traverse_ throwOnConflict patchOutcome - let seedValue = recordedValue seedJson seedOutcome - snapshotState = - maybe - (Map.singleton continueSeedStepName seedValue) - ( \outcome -> - Map.fromList - [ (continueSeedStepName, seedValue) - , (patchSetStepName, recordedValue encodedPatches outcome) - ] - ) - patchOutcome - snapshotAppend = - case patchOutcome of - Just (JournalAppended appendResult) -> Just appendResult - _ -> case seedOutcome of - JournalAppended appendResult -> Just appendResult - _ -> Nothing - for_ snapshotAppend $ \appendResult -> - writeWorkflowSnapshotAdvisory - mMetrics - (appendResult ^. #streamId) - (appendResult ^. #streamVersion) - snapshotState - -- 2. Terminal rotation marker on the CURRENT generation (audit + closes it). - appendJournal name wid gen (WorkflowContinuedAsNew nextGen now) >>= \case - JournalAppended{} -> pure () - JournalAlreadyPresent{} -> pure () - JournalAppendConflict err -> throwIO (WorkflowJournalAppendError (Text.pack (show err))) - pure ContinuedAsNew - where - condemnOnConflict = \case - JournalAppendConflict{} -> Tx.condemn - _ -> pure () - throwOnConflict = \case - JournalAppendConflict err -> - throwIO (WorkflowJournalAppendError (Text.pack (show err))) - _ -> pure () - recordedValue fallback = \case - JournalAlreadyPresent stored -> stored - _ -> fallback - -{- | Snapshot a workflow state after its journal append has committed. The -snapshot is advisory: a store failure is counted and cannot turn the -already-durable workflow transition into a failed run. --} -writeWorkflowSnapshotAdvisory :: - (IOE :> es, Store :> es, Error StoreError :> es) => - Maybe KeiroMetrics -> - StreamId -> - StreamVersion -> - WorkflowState -> - Eff es () -writeWorkflowSnapshotAdvisory mMetrics streamId version state = do - -- WorkflowState is already a Map Text Value assembled from journaled step - -- results, so this path has no aggregate RegFile/uninit encode to guard. - outcome <- tryError @StoreError (writeWorkflowSnapshot streamId version state) - case outcome of - Right () -> pure () - Left _ -> recordSnapshotWriteFailures mMetrics 1 - -instanceStatusForEvent :: WorkflowJournalEvent -> (WorkflowStatus, Maybe Text) -instanceStatusForEvent = \case - StepRecorded{} -> (WfRunning, Nothing) - WorkflowCompleted{} -> (WfCompleted, Nothing) - WorkflowCancelled{} -> (WfCancelled, Nothing) - WorkflowFailed reason _ -> (WfFailed, Just reason) - WorkflowContinuedAsNew{} -> (WfRunning, Nothing) - --- | The reserved step-name key a journal event indexes under. -journalKey :: WorkflowJournalEvent -> Text -journalKey = \case - StepRecorded{stepName = key} -> key - WorkflowCompleted{} -> completedStepName - WorkflowCancelled{} -> cancelledStepName - WorkflowFailed{} -> failedStepName - WorkflowContinuedAsNew{} -> continuedAsNewStepName - --- | The index row corresponding to a journal event, on the given generation. -journalRow :: WorkflowName -> WorkflowId -> Int -> WorkflowJournalEvent -> WorkflowStepRow -journalRow name wid gen = \case - StepRecorded key value t -> - WorkflowStepRow - { workflowId = unWorkflowId wid - , workflowName = unWorkflowName name - , generation = gen - , stepName = key - , result = value - , recordedAt = t - } - WorkflowCompleted t -> - WorkflowStepRow - { workflowId = unWorkflowId wid - , workflowName = unWorkflowName name - , generation = gen - , stepName = completedStepName - , result = Aeson.Null - , recordedAt = t - } - WorkflowCancelled t -> - WorkflowStepRow - { workflowId = unWorkflowId wid - , workflowName = unWorkflowName name - , generation = gen - , stepName = cancelledStepName - , result = Aeson.Null - , recordedAt = t - } - WorkflowFailed r t -> - WorkflowStepRow - { workflowId = unWorkflowId wid - , workflowName = unWorkflowName name - , generation = gen - , stepName = failedStepName - , result = Aeson.toJSON r - , recordedAt = t - } - WorkflowContinuedAsNew g t -> - WorkflowStepRow - { workflowId = unWorkflowId wid - , workflowName = unWorkflowName name - , generation = gen - , stepName = continuedAsNewStepName - , result = Aeson.toJSON g -- the NEXT generation this rotation opens - , recordedAt = t - } - -{- | A stable, collision-resistant journal-event id from -@("keiro" : "workflow" : name : id : generation : stepName)@ via a v5 UUID. -Mirrors 'Keiro.ProcessManager.deterministicCommandId': the same inputs always -yield the same id, so a re-append of the same step collapses to the same row. - -The /generation/ (EP-48) is part of the id so a step named @"s1"@ in -generation 0 and the same name in generation 1 produce __different__ kiroku -event ids — they live on different physical streams, but the event id is -global, so namespacing it by generation keeps rotated generations from -colliding on the deterministic id. --} -deterministicJournalId :: WorkflowName -> WorkflowId -> Int -> Text -> EventId -deterministicJournalId (WorkflowName name) (WorkflowId wid) gen key = - EventId $ - UUID.V5.generateNamed UUID.V5.namespaceURL $ - fmap (fromIntegral . fromEnum) $ - Text.unpack $ - Text.intercalate ":" ["keiro", "workflow", name, wid, Text.pack (show gen), key] +-- | The durable workflow runtime: the @Workflow@ effect, named-step +-- journaling, replay, and suspension. +-- +-- == What this gives you +-- +-- Write a long-running process as an ordinary @effectful@ computation and run +-- it with 'runWorkflow'. Each @'step' name action@ either runs @action@ and +-- records ("journals") its result, or — on a replay after a crash — returns the +-- previously recorded result /without/ re-running the side effect. The journal +-- is a kiroku stream named @wf:\-\@ ('workflowStreamName'); there is +-- no separate history table. Because a workflow can pause (waiting for a timer, +-- an external signal, or a child), 'runWorkflow' returns a 'WorkflowOutcome' +-- ('Completed' or 'Suspended'). +-- +-- Step side effects are at-least-once across process crashes. If the process +-- crashes after @action@ runs but before the journal append commits, a later +-- resume has no record of that step and runs @action@ again. Step bodies that call +-- external systems must therefore be idempotent, typically by deriving an +-- idempotency key from the workflow identity and step name and passing it to the +-- external system. +-- +-- Replay is keyed by step name, not by source position or code identity. Renaming +-- a step intentionally orphans the old journal entry and runs the renamed step as +-- new work; changing the meaning of a step while keeping the same name is the +-- author's responsibility. Use 'patch' for cross-cutting workflow-body changes +-- that need an explicit old/new branch. +-- +-- == Contract recap for downstream plans (the v2 MasterPlan) +-- +-- * The authoring surface is the @Workflow@ effect with 'step', 'awaitStep', +-- 'currentWorkflow', and 'freshOrdinal'. Add new primitives (sleep, +-- awakeable, child) as functions that go /through/ this effect so a single +-- import stays the workflow surface. +-- * 'awaitStep' is the suspension primitive every wake source builds on: it +-- returns a journaled result if present, otherwise runs an idempotent +-- /arming/ action once and suspends the run. The arming action MUST be +-- idempotent — a suspended-then-resumed workflow re-enters 'awaitStep' from +-- the top on every resume until the result is journaled, so it re-runs @arm@ +-- each time (e.g. schedule a timer with a deterministic id so repeats +-- collapse to a no-op). +-- * A wake source's external completion path (a timer firing, +-- @signalAwakeable@, a child finishing) calls 'appendJournalEntry' (or +-- 'appendJournalEntryReturningId') with a 'StepRecorded' whose @stepName@ is +-- the awaited step name; the next 'runWorkflow' then takes the 'awaitStep' +-- hit path and proceeds. +-- * The journal codec ('workflowJournalCodec') and the reserved step-name +-- prefixes ('sleepStepPrefix' = @"sleep:"@, 'awakeableStepPrefix' = @"awk:"@, +-- 'childStepPrefix' = @"child:"@) are integration contracts: suspensions are +-- journaled as ordinary 'StepRecorded' events with these prefixes, never as +-- new event types, so the replay loop stays uniform. +-- * Per-run options live in one record, 'WorkflowRunOptions' (EP-41 adds a +-- snapshot policy, EP-44 adds metrics/tracer); 'runWorkflowWith' is the +-- single canonical entry EP-42's resume worker re-invokes through. +-- * The derived @keiro_workflows@ instance row is maintained by journal append +-- transactions. Terminal markers ('WorkflowCompleted', 'WorkflowCancelled', +-- 'WorkflowFailed') freeze the instance as completed/cancelled/failed, and the +-- resume worker uses its attempt/lease fields for crash recovery. +-- * Discovery (EP-42) is 'findUnfinishedWorkflowIds' plus 'completedStepName'; +-- it needs no kiroku prefix subscription. +-- +-- > __Build gotcha__ (EP-38's migration adds @keiro_workflow_steps@): adding a +-- > new @.sql@ file under @keiro-migrations/sql-migrations/@ does not trigger +-- > recompilation of @Keiro.Migrations@ (cabal says "Up to date" even with +-- > @-fforce-recomp@, because @embedDir@ is a Template Haskell directory read +-- > GHC's recompilation checker does not track per-file). After adding a +-- > migration, edit a comment in @keiro-migrations/src/Keiro/Migrations.hs@ or +-- > run @cabal clean@ before building. +module Keiro.Workflow + ( -- * The effect and authoring surface + Workflow, + step, + awaitStep, + currentWorkflow, + currentRunGeneration, + freshOrdinal, + continueAsNew, + restoreSeed, + patch, + + -- * Running a workflow + runWorkflow, + runWorkflowWith, + WorkflowRunOptions (..), + LeaseHeartbeat (..), + defaultWorkflowRunOptions, + + -- * Journal append helpers (used by wake-source plans) + JournalAppendOutcome (..), + prepareJournalAppend, + appendJournalEntry, + appendJournalEntryReturningId, + deterministicJournalId, + + -- * Errors thrown by the runtime + WorkflowError (..), + WorkflowLeaseLost (..), + + -- * Re-exported core contracts + module Keiro.Workflow.Types, + WorkflowStepRow (..), + recordStepTx, + loadStepIndex, + stepExists, + currentGeneration, + findUnfinishedWorkflowIds, + setWorkflowWakeAfterTx, + clearWorkflowWakeAfterTx, + ) +where + +import Control.Exception (Exception) +import Data.Aeson qualified as Aeson +import Data.IORef + ( IORef, + atomicModifyIORef', + newIORef, + readIORef, + ) +import Data.Int (Int32) +import Data.Map.Strict (Map) +import Data.Map.Strict qualified as Map +import Data.Set (Set) +import Data.Set qualified as Set +import Data.Text qualified as Text +import Data.Time (NominalDiffTime) +import Data.UUID.V5 qualified as UUID.V5 +import Effectful (Dispatch (..), DispatchOf, Eff, Effect, IOE, (:>)) +import Effectful.Dispatch.Dynamic (EffectHandler, interpret, localSeqUnlift, send) +import Effectful.Error.Static (Error, tryError) +import Effectful.Exception (bracket_, catch, throwIO) +import Keiro.Codec (decodeRecorded, encodeForAppendWithMetadata) +import Keiro.EventStream (SnapshotPolicy (..), Terminality (..)) +import Keiro.Prelude +import Keiro.Snapshot (SnapshotMissReason (..)) +import Keiro.Snapshot.Policy (shouldSnapshot) +import Keiro.Telemetry + ( KeiroMetrics, + Tracer, + recordSnapshotDecodeFailures, + recordSnapshotReadHits, + recordSnapshotReadMisses, + recordSnapshotWriteFailures, + recordWorkflowActive, + recordWorkflowJournalLength, + recordWorkflowStepExecuted, + recordWorkflowStepReplayed, + withWorkflowSpan, + ) +import Keiro.Workflow.Instance + ( WorkflowStatus (..), + markInstanceSuspended, + renewInstanceLease, + upsertInstanceTx, + ) +import Keiro.Workflow.Schema (WorkflowStepRow (..), clearWorkflowWakeAfterTx, currentGeneration, findUnfinishedWorkflowIds, loadStepIndex, lockWorkflowStepTx, lookupStepResult, lookupStepResultTx, recordStepTx, setWorkflowWakeAfterTx, stepExists) +import Keiro.Workflow.Snapshot (lookupWorkflowSnapshot, writeWorkflowSnapshot) +import Keiro.Workflow.Types +import Kiroku.Store.Effect (Store) +import Kiroku.Store.Error (StoreError) +import Kiroku.Store.Read (readStreamForwardStream) +import Kiroku.Store.Transaction (AppendConflict, appendToStreamTx, prepareEventsIO, runTransaction) +import Kiroku.Store.Types (AppendResult (..), EventData, EventId (..), ExpectedVersion (..), StreamId, StreamVersion (..)) +import Streamly.Data.Fold qualified as Fold +import Streamly.Data.Stream qualified as Streamly +import System.IO.Unsafe (unsafePerformIO) +import "hasql-transaction" Hasql.Transaction qualified as Tx + +-- --------------------------------------------------------------------------- +-- The effect +-- --------------------------------------------------------------------------- + +-- | The durable workflow effect. Its operations are interpreted by +-- 'runWorkflow' / 'runWorkflowWith', which journal and replay them. +data Workflow :: Effect where + -- | Run a side-effecting action under a name, journaling its result; on + -- replay, return the recorded result without re-running the action. + Step :: (Aeson.ToJSON a, Aeson.FromJSON a) => StepName -> m a -> Workflow m a + -- | Return the awaited step's journaled result, or run the (idempotent) + -- arming action once and suspend the run. + Await :: (Aeson.FromJSON a) => StepName -> m () -> Workflow m a + -- | The running workflow's identity (for keying wake sources). + CurrentWorkflow :: Workflow m (WorkflowName, WorkflowId) + -- | The journal generation this run is operating on. + CurrentRunGeneration :: Workflow m Int + -- | A per-run, per-namespace counter for deterministic ordinal step names. + FreshOrdinal :: Text -> Workflow m Int + -- | EP-48: snapshot the carried seed, rotate onto a fresh journal generation, + -- and unwind this run; the next run/resume continues from the seed. Never + -- returns to the caller within this run (result type is fully polymorphic). + ContinueAsNew :: (Aeson.ToJSON s) => s -> Workflow m a + -- | EP-49: decide and journal a cross-cutting branch — returns the stable + -- 'Bool' branch decision for the given patch. Fresh instances get 'True' + -- (new branch); instances already in flight when the patch shipped get + -- 'False' (old branch). The decision is journaled on first encounter and + -- replayed verbatim thereafter. + Patch :: PatchId -> Workflow m Bool + +type instance DispatchOf Workflow = Dynamic + +-- | Run @action@ under @name@, journaling its encoded result. On a replay where +-- @name@ is already journaled, the recorded result is returned and @action@ is +-- not run. If the process crashed after @action@ ran but before the journal +-- commit, the action runs again on resume: workflow step side effects are +-- at-least-once at the step boundary. +-- +-- The returned value is always the JSON round-trip of the recorded result, +-- including on the first run. A lossy or rejecting @ToJSON@\/@FromJSON@ pair is +-- therefore observed immediately rather than only after a crash and replay. +-- +-- Requires @'Aeson.ToJSON' a@ (to journal the result) and @'Aeson.FromJSON' a@ +-- (to decode it on replay). +step :: (Workflow :> es, Aeson.ToJSON a, Aeson.FromJSON a) => StepName -> Eff es a -> Eff es a +step name action = send (Step name action) + +-- | Look up @name@ in the journal. If a wake source has already recorded its +-- completion (a 'StepRecorded' whose @stepName@ is @name@, carrying the +-- resolved result), decode and return it. Otherwise run @arm@ exactly once +-- (the wake source's idempotent job — schedule a timer, register an awakeable, +-- spawn a child) and __suspend__ this run, so 'runWorkflow' returns 'Suspended'. +-- +-- @arm@ must be idempotent: every resume re-runs it until the result is +-- journaled. +awaitStep :: (Workflow :> es, Aeson.FromJSON a) => StepName -> Eff es () -> Eff es a +awaitStep name arm = send (Await name arm) + +-- | The identity of the workflow currently running. +currentWorkflow :: (Workflow :> es) => Eff es (WorkflowName, WorkflowId) +currentWorkflow = send CurrentWorkflow + +-- | The journal generation this run is operating on. Wake sources include it +-- in their durable identities so a generation opened by 'continueAsNew' never +-- collides with prior-generation rows. +currentRunGeneration :: (Workflow :> es) => Eff es Int +currentRunGeneration = send CurrentRunGeneration + +-- | A per-run, per-namespace counter (starting at 0). Used by convenience +-- forms of wake sources (e.g. @sleep@ → @"sleep:0"@) to derive a deterministic, +-- replay-stable ordinal name. Note: ordinal names are only stable if the order +-- of @awaitStep@-style calls does not change across deploys; the named forms +-- are the stable primitives. +freshOrdinal :: (Workflow :> es) => Text -> Eff es Int +freshOrdinal namespace = send (FreshOrdinal namespace) + +-- | Continue this workflow /as new/ (EP-48): snapshot the carried @seed@ onto a +-- fresh journal generation, journal a terminal rotation marker on the current +-- generation, and unwind this run. The next run or resume of the same logical +-- @('WorkflowName', 'WorkflowId')@ starts against the fresh generation, hydrated +-- from the seed, with an empty (bounded) journal. +-- +-- This is how a workflow that runs an /unbounded/ number of steps — a poller, a +-- per-day rolling process — keeps its per-generation journal bounded so replay +-- and hydration stay fast forever. The result type is fully polymorphic (@a@) +-- because control never returns to the caller within /this/ run: the rotated +-- continuation runs in the next run/resume. Read the carried seed back at the top +-- of the workflow body with 'restoreSeed'. +continueAsNew :: (Workflow :> es, Aeson.ToJSON s) => s -> Eff es a +continueAsNew seed = send (ContinueAsNew seed) + +-- | Restore the seed carried by the previous generation's 'continueAsNew', or +-- return @def@ on the first generation (EP-48). Implemented as an ordinary +-- journaled @step@ under the reserved 'continueSeedStepName': on a generation that +-- was rotated into, the seed step was journaled (and snapshotted) by the rotation, +-- so this @step@ hits it and returns the carried value without re-running; on the +-- very first generation it misses and records @def@. Call it once at the top of a +-- workflow body that uses 'continueAsNew'. +restoreSeed :: (Workflow :> es, Aeson.ToJSON s, Aeson.FromJSON s) => s -> Eff es s +restoreSeed def = step (StepName continueSeedStepName) (pure def) + +-- | Decide a cross-cutting branch for an in-flight-vs-fresh code change, and +-- journal the decision so every later replay observes the same branch (EP-49). +-- +-- @patch (PatchId "fraud-check-v2")@ returns 'True' only when that id was present +-- in 'activePatches' when this workflow generation first started. The generation +-- records its active set under 'patchSetStepName' exactly once; on the first +-- encounter each individual patch decision is journaled under @patch:\@, +-- and every replay returns the recorded 'Bool'. Add a patch id to 'activePatches' +-- in the deploy that introduces the corresponding 'patch' call; remove it only +-- after deleting that call from the workflow body. +-- +-- This is an /escape hatch/ for changes that cross-cut multiple steps. For the +-- common case — one step changed — do __not__ use 'patch': rename the step's +-- 'StepName' instead. A renamed step has no journaled history under its new name, +-- so its action runs fresh on the next replay, which is exactly the right +-- behaviour for a single-step change. Reach for 'patch' only when an in-flight +-- instance would be left incoherent by the new code (e.g. the change adds, removes, +-- or reorders steps, or changes the meaning of an already-journaled step result). +patch :: (Workflow :> es) => PatchId -> Eff es Bool +patch pid = send (Patch pid) + +-- --------------------------------------------------------------------------- +-- Per-run options +-- --------------------------------------------------------------------------- + +-- | Lease renewal coordinates for a resume-worker-owned workflow run. +-- +-- The runtime renews this lease immediately before each fresh step action and +-- unresolved await arm. Direct 'runWorkflow' calls leave it 'Nothing'. +data LeaseHeartbeat = LeaseHeartbeat + { owner :: !Text, + ttl :: !NominalDiffTime + } + deriving stock (Generic, Eq, Show) + +-- | Options for a single workflow run. This is the canonical home for +-- per-run options across the v2 initiative — EP-41 adds the snapshot policy, +-- EP-44 adds metrics/tracer fields, all additive. Extend it additively; never +-- break the field set EP-38/EP-41 established. +data WorkflowRunOptions = WorkflowRunOptions + { -- | When to persist a snapshot of the accumulated step-result map after a + -- step append (and at completion, for 'OnTerminal'). Default 'Never' + -- (EP-38 behaviour: every run/resume does a full version-0 replay). + snapshotPolicy :: !(SnapshotPolicy WorkflowState), + -- | Page size for the journal pre-load read. + pageSize :: !Int32, + -- | EP-44: when 'Just', the runtime records the @keiro.workflow.*@ instruments + -- (steps executed/replayed, active count, journal length). 'Nothing' is the + -- no-op default, so a run with 'defaultWorkflowRunOptions' records nothing. + metrics :: !(Maybe KeiroMetrics), + -- | EP-44: when 'Just', the runtime opens a @workflow \@ 'Internal' span + -- around the run. 'Nothing' runs the body unwrapped. + tracer :: !(Maybe Tracer), + -- | Patch ids currently active in this deployed workflow code. A fresh + -- workflow generation records this set once under 'patchSetStepName', and + -- each 'patch' call returns 'True' iff its id was in that recorded set. + activePatches :: !(Set PatchId), + -- | Resume-worker lease coordinates. When present, fresh workflow + -- boundaries renew the lease and throw 'WorkflowLeaseLost' if another owner + -- has taken it. 'Nothing' keeps direct runs free of lease traffic. + leaseHeartbeat :: !(Maybe LeaseHeartbeat) + } + deriving stock (Generic) + +-- | Sensible defaults: no snapshotting, a journal pre-load page size of 100, +-- and no telemetry (metrics/tracer 'Nothing'). A default-options run replays +-- and behaves exactly as EP-38 did. +defaultWorkflowRunOptions :: WorkflowRunOptions +defaultWorkflowRunOptions = + WorkflowRunOptions + { snapshotPolicy = Never, + pageSize = 100, + metrics = Nothing, + tracer = Nothing, + activePatches = Set.empty, + leaseHeartbeat = Nothing + } + +-- --------------------------------------------------------------------------- +-- Errors and the suspension sentinel +-- --------------------------------------------------------------------------- + +-- | Errors the workflow runtime raises (via 'throwIO', so they surface +-- through the surrounding store/IO error channel). +data WorkflowError + = -- | A journaled step result could not be decoded into the type the + -- replaying @step@/@awaitStep@ expects (step name, decode message). The + -- result type changed incompatibly — a programmer error. + WorkflowStepDecodeError !Text !Text + | -- | A journal event could not be decoded during pre-load. + WorkflowJournalDecodeError !Text + | -- | A journal event could not be encoded for append. + WorkflowJournalEncodeError !Text + | -- | Appending a journal entry failed for a non-conflict reason. + WorkflowJournalAppendError !Text + deriving stock (Eq, Show) + +instance Exception WorkflowError + +-- | The resume worker no longer owns the workflow instance lease. +-- +-- Thrown before a fresh step action or unresolved await arm, so the run stops +-- before performing further side effects. Resume workers classify this as a +-- lease skip rather than a workflow crash. +data WorkflowLeaseLost = WorkflowLeaseLost + deriving stock (Eq, Show) + +instance Exception WorkflowLeaseLost + +-- | Internal sentinel thrown to unwind a suspended run up to 'runWorkflowWith'. +data WorkflowSuspend = WorkflowSuspend + deriving stock (Show) + +instance Exception WorkflowSuspend + +-- | Internal sentinel thrown when a cancellation marker appears mid-run. +data WorkflowCancelPending = WorkflowCancelPending + deriving stock (Show) + +instance Exception WorkflowCancelPending + +-- | Internal sentinel thrown by the 'ContinueAsNew' handler to unwind a +-- rotating run up to 'runWorkflowWith' (EP-48), carrying the JSON-encoded seed for +-- the next generation. Mirrors 'WorkflowSuspend': a non-returning unwind the run +-- entry point catches and turns into an outcome ('ContinuedAsNew'). +newtype WorkflowRotate = WorkflowRotate Aeson.Value + deriving stock (Show) + +instance Exception WorkflowRotate + +-- --------------------------------------------------------------------------- +-- Running +-- --------------------------------------------------------------------------- + +-- | Process-wide count of workflow runs currently in flight, backing the +-- @keiro.workflow.active@ gauge (EP-44). 'runWorkflowWith' brackets each run with +-- @+1@/@-1@ and samples the gauge on both edges, so the exported last-value +-- reflects the true live count whether a run is mid-flight or finished. A +-- process-global 'IORef' is the lightest faithful implementation (the gauge is a +-- last-value-wins level, not a per-run delta), mirroring how the other keiro +-- backlog/level gauges are recorded with a value the runtime already holds. +{-# NOINLINE activeCountRef #-} +activeCountRef :: IORef Int64 +activeCountRef = unsafePerformIO (newIORef 0) + +-- | Run a workflow computation, journaling each 'step' and replaying any +-- already-journaled steps. Returns 'Completed' when the computation finishes +-- (a 'WorkflowCompleted' marker is journaled) or 'Suspended' when it pauses at +-- an unresolved 'awaitStep'. +-- +-- Equivalent to @'runWorkflowWith' 'defaultWorkflowRunOptions'@. +runWorkflow :: + (IOE :> es, Store :> es, Error StoreError :> es) => + WorkflowName -> + WorkflowId -> + Eff (Workflow : es) a -> + Eff es (WorkflowOutcome a) +runWorkflow = runWorkflowWith defaultWorkflowRunOptions + +-- | 'runWorkflow' with explicit 'WorkflowRunOptions'. This is the single +-- canonical run entry point; EP-42's resume worker re-invokes through it so +-- resumed runs honor the same options. +-- +-- If the workflow's journal already carries a 'WorkflowCancelled' marker (a child +-- cancelled by its parent, EP-43), the run short-circuits immediately and returns +-- 'Cancelled' without executing any step. The handler also re-checks that marker +-- on step/await/patch miss paths and after a fresh step action returns, so a +-- mid-run cancellation stops at the next workflow boundary. A cancellation that +-- lands after the check but before/during the user action may still let that one +-- action run; durable workflow steps remain at-least-once at boundaries. If the +-- journal carries a 'WorkflowFailed' marker, the run likewise short-circuits to +-- 'Failed'. To /propagate/ a finished child's result to its parent, drive the +-- child through 'Keiro.Workflow.Child.runChildWorkflow' rather than this function +-- directly. +runWorkflowWith :: + forall a es. + (IOE :> es, Store :> es, Error StoreError :> es) => + WorkflowRunOptions -> + WorkflowName -> + WorkflowId -> + Eff (Workflow : es) a -> + Eff es (WorkflowOutcome a) +runWorkflowWith options name wid action = do + -- EP-48: resolve the CURRENT (highest) generation once per run and operate + -- only on it. A never-rotating workflow stays at generation 0, so naming, + -- load, and append are byte-for-byte as before. A rotated workflow resolves + -- to its newest generation, so discovery/resume transparently continue there. + gen <- currentGeneration name wid + -- Cancellation short-circuit (EP-43): a workflow whose journal carries a + -- WorkflowCancelled marker makes no further progress. The index row for that + -- marker is keyed under 'cancelledStepName' on the current generation, so a + -- single existence check is enough and we never run the user action. + cancelled <- stepExists name wid gen cancelledStepName + failed <- stepExists name wid gen failedStepName + case (cancelled, failed) of + (True, _) -> pure Cancelled + (_, True) -> pure Failed + _ -> runActive gen + where + -- EP-44 telemetry handles, pulled from the run options once. Both default + -- to 'Nothing' (see 'defaultWorkflowRunOptions'), so a default-options run + -- records nothing and opens no span — the no-op idiom holds end to end. + mMetrics = options ^. #metrics + mTracer = options ^. #tracer + runActive :: Int -> Eff es (WorkflowOutcome a) + runActive gen = + -- EP-44: maintain the process-wide live-run count and sample the + -- @keiro.workflow.active@ gauge on both entry and exit, and open the + -- whole-run @workflow \@ span (step 'Nothing'). The body is + -- unchanged from EP-41 except for the journal-length recording below. + bracket_ + (liftIO (atomicModifyIORef' activeCountRef (\n -> (n + 1, ()))) >> sampleActive) + (liftIO (atomicModifyIORef' activeCountRef (\n -> (n - 1, ()))) >> sampleActive) + (withWorkflowSpan mTracer name wid Nothing (\_sp -> interpreted)) + where + sampleActive = liftIO (readIORef activeCountRef) >>= recordWorkflowActive mMetrics + interpreted = do + initial <- loadJournal options name wid gen + initial' <- recordPatchSetIfFresh gen initial + journalRef <- liftIO (newIORef initial') + ordinalRef <- liftIO (newIORef Map.empty) + let runHandler = interpret (handler gen journalRef ordinalRef) action + outcome <- + (Completed <$> runHandler) + `catch` (\WorkflowSuspend -> pure Suspended) + `catch` (\WorkflowCancelPending -> pure Cancelled) + `catch` ( \(WorkflowRotate seedJson) -> + rotateGeneration + mMetrics + (options ^. #activePatches) + name + wid + gen + seedJson + ) + case outcome of + Completed result -> do + now <- liftIO getCurrentTime + finalMap <- liftIO (readIORef journalRef) + -- Idempotent: only appends (and so only snapshots) when the completion + -- marker is not already journaled. On a replay of an already-completed + -- workflow this is 'Nothing' and no terminal snapshot is taken (one was + -- already taken on the original completing run, if the policy fired). + mAppend <- appendCompletion name wid gen now + for_ mAppend $ \appendResult -> + when + ( shouldSnapshot + (options ^. #snapshotPolicy) + Terminal + finalMap + (appendResult ^. #streamVersion) + ) + (writeWorkflowSnapshotAdvisory mMetrics (appendResult ^. #streamId) (appendResult ^. #streamVersion) finalMap) + -- EP-44: record one @keiro.workflow.journal.length@ observation per + -- completing run (the 'Completed' path only, never 'Suspended'), + -- including a replay that completes again. Length is the recorded + -- step map plus the WorkflowCompleted marker. + recordWorkflowJournalLength mMetrics (fromIntegral (Map.size finalMap + 1)) + pure (Completed result) + Suspended -> markInstanceSuspended name wid >> pure Suspended + Cancelled -> pure Cancelled + Failed -> pure Failed + -- EP-48: the run unwound via 'WorkflowRotate'; 'rotateGeneration' + -- already journaled the seed step on the next generation and the + -- rotation marker on this one, so there is nothing more to do here. + ContinuedAsNew -> pure ContinuedAsNew + -- Generation 0 has no rotation moment at which to record the patch set, + -- so it retains the fresh-journal path. Rotated generations receive the + -- set atomically with their seed in 'rotateGeneration'; this fallback + -- also keeps generations produced by a pre-change worker compatible. + recordPatchSetIfFresh runGen initial = do + let patches = options ^. #activePatches + freshStart = Map.keysSet initial `Set.isSubsetOf` Set.singleton continueSeedStepName + if freshStart && not (Set.null patches) + then do + let encoded = Aeson.toJSON (map unPatchId (Set.toList patches)) + now <- liftIO getCurrentTime + appendJournal name wid runGen (StepRecorded patchSetStepName encoded now) >>= \case + JournalAppended {} -> pure (Map.insert patchSetStepName encoded initial) + JournalAlreadyPresent stored -> pure (Map.insert patchSetStepName stored initial) + JournalAppendConflict err -> throwIO (WorkflowJournalAppendError (Text.pack (show err))) + else pure initial + handler :: + Int -> + IORef (Map Text Aeson.Value) -> + IORef (Map Text Int) -> + EffectHandler Workflow es + handler gen journalRef ordinalRef env operation = case operation of + Step (StepName key) act -> do + journal <- liftIO (readIORef journalRef) + case Map.lookup key journal of + Just stored -> do + -- Hit: the step is already journaled, so its recorded result is + -- returned without re-running @act@ — a replay. + recordWorkflowStepReplayed mMetrics 1 + decodeStored key stored + Nothing -> do + renewLease + checkCancellationPending name wid gen + a <- localSeqUnlift env (\unlift -> unlift act) + checkCancellationPending name wid gen + let encoded = Aeson.toJSON a + now <- liftIO getCurrentTime + appendOutcome <- appendJournal name wid gen (StepRecorded key encoded now) + case appendOutcome of + JournalAppended appendResult -> do + -- Miss: @act@ ran and was journaled — a fresh execution. + recordWorkflowStepExecuted mMetrics 1 + newMap <- + liftIO + ( atomicModifyIORef' journalRef $ \m -> + let m' = Map.insert key encoded m in (m', m') + ) + -- Evaluate the snapshot policy on the post-append map and version; + -- a step is never the terminal marker, hence @False@. + when + ( shouldSnapshot + (options ^. #snapshotPolicy) + NotTerminal + newMap + (appendResult ^. #streamVersion) + ) + (writeWorkflowSnapshotAdvisory mMetrics (appendResult ^. #streamId) (appendResult ^. #streamVersion) newMap) + decodeStored key encoded + JournalAlreadyPresent stored -> do + liftIO + ( atomicModifyIORef' journalRef $ \m -> + (Map.insert key stored m, ()) + ) + decodeStored key stored + JournalAppendConflict err -> + throwIO (WorkflowJournalAppendError (Text.pack (show err))) + Await (StepName key) arm -> do + journal <- liftIO (readIORef journalRef) + case Map.lookup key journal of + Just stored -> do + -- An awaitStep hit means the wake source already resolved this step; + -- the recorded result is returned without arming — a replay. An + -- awaitStep miss arms and suspends: no user @action@ ran, so it is + -- not a step execution and records nothing here. + recordWorkflowStepReplayed mMetrics 1 + decodeStored key stored + Nothing -> + -- The in-memory map can omit a wake completion journaled + -- while a snapshotting run was mid-flight. The step index + -- is written transactionally with every append, so consult + -- it before arming and suspending. + lookupStepResult name wid gen key >>= \case + Just stored -> do + liftIO + ( atomicModifyIORef' journalRef $ \m -> + (Map.insert key stored m, ()) + ) + recordWorkflowStepReplayed mMetrics 1 + decodeStored key stored + Nothing -> do + renewLease + checkCancellationPending name wid gen + localSeqUnlift env (\unlift -> unlift arm) + throwIO WorkflowSuspend + CurrentWorkflow -> pure (name, wid) + CurrentRunGeneration -> pure gen + FreshOrdinal namespace -> + liftIO . atomicModifyIORef' ordinalRef $ \counters -> + let n = Map.findWithDefault 0 namespace counters + in (Map.insert namespace (n + 1) counters, n) + -- EP-48: encode the carried seed and throw the rotation sentinel, which + -- 'runWorkflowWith' catches and turns into 'rotateGeneration'. Never + -- returns to the caller within this run (result type is polymorphic). + ContinueAsNew seed -> throwIO (WorkflowRotate (Aeson.toJSON seed)) + -- EP-49: decide and journal a cross-cutting branch. Mirrors the 'Step' + -- hit/miss shape, but the miss path computes the decision from the + -- patch set recorded when this workflow generation first started. + Patch pid -> do + let key = patchStepName pid + journal <- liftIO (readIORef journalRef) + case Map.lookup key journal of + Just stored -> + -- Hit: the decision was made on an earlier run; replay it verbatim. + decodeStored key stored + Nothing -> do + checkCancellationPending name wid gen + recordedSet <- case Map.lookup patchSetStepName journal of + Nothing -> pure [] + Just stored -> decodeStored patchSetStepName stored + let decision = unPatchId pid `elem` (recordedSet :: [Text]) + encoded = Aeson.toJSON decision + now <- liftIO getCurrentTime + appendOutcome <- appendJournal name wid gen (StepRecorded key encoded now) + case appendOutcome of + JournalAppended {} -> do + liftIO + ( atomicModifyIORef' journalRef $ \m -> + (Map.insert key encoded m, ()) + ) + pure decision + JournalAlreadyPresent stored -> do + liftIO + ( atomicModifyIORef' journalRef $ \m -> + (Map.insert key stored m, ()) + ) + decodeStored key stored + JournalAppendConflict err -> + throwIO (WorkflowJournalAppendError (Text.pack (show err))) + where + renewLease = + for_ (options ^. #leaseHeartbeat) $ \heartbeat -> do + renewed <- + renewInstanceLease + (heartbeat ^. #owner) + (heartbeat ^. #ttl) + name + wid + unless renewed (throwIO WorkflowLeaseLost) + +-- | Decode a stored journal result into the type the caller expects. +decodeStored :: (Aeson.FromJSON a) => Text -> Aeson.Value -> Eff es a +decodeStored key stored = case Aeson.fromJSON stored of + Aeson.Success a -> pure a + Aeson.Error message -> throwIO (WorkflowStepDecodeError key (Text.pack message)) + +checkCancellationPending :: (Store :> es) => WorkflowName -> WorkflowId -> Int -> Eff es () +checkCancellationPending name wid gen = do + cancelled <- stepExists name wid gen cancelledStepName + when cancelled (throwIO WorkflowCancelPending) + +-- | Pre-load a workflow's journal stream into a @step name -> result@ map. +-- +-- If a compatible snapshot exists ('loadWorkflowSnapshot'), seed the map from it +-- and read only the journal events /after/ the snapshot's version ("tail +-- replay"). The reconstructed map is the journal state as the snapshotting run +-- saw it. A wake completion journaled concurrently with that run can fall at or +-- before the snapshot version yet be absent from the seed, so the map may +-- under-approximate the journal. The @Await@ handler compensates by consulting +-- the authoritative @keiro_workflow_steps@ index on a map miss; that index is +-- written transactionally with every journal append. +-- +-- A missing, mismatched, or undecodable snapshot is recorded as a miss (and, for +-- undecodable bytes, a decode failure) before the read falls back to a full +-- replay from version 0. +-- 'WorkflowCompleted' contributes nothing to the map. +loadJournal :: + (IOE :> es, Store :> es) => + WorkflowRunOptions -> + WorkflowName -> + WorkflowId -> + Int -> + Eff es (Map Text Aeson.Value) +loadJournal options name wid gen = do + let journalName = workflowGenerationStreamName name wid gen + snapshot <- lookupWorkflowSnapshot journalName + (seedMap, fromVersion) <- case snapshot of + Right (m, v) -> do + recordSnapshotReadHits (options ^. #metrics) 1 + pure (m, v) + Left reason -> do + recordSnapshotReadMisses (options ^. #metrics) 1 + case reason of + SnapshotDecodeFailed _ -> recordSnapshotDecodeFailures (options ^. #metrics) 1 + _ -> pure () + pure (Map.empty, StreamVersion 0) + let events = readStreamForwardStream journalName fromVersion (options ^. #pageSize) + Streamly.fold (Fold.foldlM' accumulate (pure seedMap)) events + where + accumulate journal recorded = + case decodeRecorded workflowJournalCodec recorded of + Right (StepRecorded key value _) -> pure (Map.insert key value journal) + Right (WorkflowCompleted _) -> pure journal + Right (WorkflowCancelled _) -> pure journal + Right (WorkflowFailed _ _) -> pure journal + Right (WorkflowContinuedAsNew _ _) -> pure journal -- a rotation marker carries no step result + Left err -> throwIO (WorkflowJournalDecodeError (Text.pack (show err))) + +-- --------------------------------------------------------------------------- +-- Journal append helpers +-- --------------------------------------------------------------------------- + +data JournalAppendOutcome + = JournalAppended !AppendResult + | JournalAlreadyPresent !Aeson.Value + | JournalAppendConflict !AppendConflict + deriving stock (Eq, Show) + +prepareJournalAppend :: + (IOE :> es) => + WorkflowName -> + WorkflowId -> + Int -> + WorkflowJournalEvent -> + Eff es (Tx.Transaction JournalAppendOutcome) +prepareJournalAppend name wid gen event = do + let key = journalKey event + entryId = deterministicJournalId name wid gen key + requestedEntryId = case event of + -- Resurrection removes the derived failure-marker index row while + -- retaining append-only journal history. A later failure on the + -- same generation therefore needs a fresh UUIDv7; step locking and + -- the in-transaction index check still deduplicate concurrent + -- failure writers. + WorkflowFailed {} -> Nothing + _ -> Just entryId + row = journalRow name wid gen event + (status, mLastError) = instanceStatusForEvent event + journalName = workflowGenerationStreamName name wid gen + lockKey = + Text.intercalate + "/" + [unWorkflowId wid, unWorkflowName name, Text.pack (show gen), key] + base <- case encodeForAppendWithMetadata workflowJournalCodec Nothing event of + Right encoded -> pure encoded + Left err -> throwIO (WorkflowJournalEncodeError (Text.pack (show err))) + let entry = base & #eventId .~ requestedEntryId :: EventData + prepared <- prepareEventsIO [entry] + now <- liftIO getCurrentTime + pure $ do + lockWorkflowStepTx lockKey + lookupStepResultTx (unWorkflowId wid) (unWorkflowName name) gen key >>= \case + Just stored -> pure (JournalAlreadyPresent stored) + Nothing -> + appendToStreamTx journalName AnyVersion prepared now >>= \case + Left err -> pure (JournalAppendConflict err) + Right appendResult -> + JournalAppended appendResult + <$ recordStepTx row + <* upsertInstanceTx + (unWorkflowId wid) + (unWorkflowName name) + (fromIntegral gen) + status + mLastError + +appendJournal :: (IOE :> es, Store :> es) => WorkflowName -> WorkflowId -> Int -> WorkflowJournalEvent -> Eff es JournalAppendOutcome +appendJournal name wid gen event = + prepareJournalAppend name wid gen event >>= runTransaction + +-- | Append a journal event to a workflow's journal stream (and keep its +-- index row consistent), idempotently. If the entry already exists this is a +-- no-op returning the would-be event id. +-- +-- This is the integration helper a wake source's external-completion path uses +-- to record an awaited step's resolution. The append uses a deterministic event +-- id derived from @("keiro" : "workflow" : name : id : stepName)@ so concurrent +-- or retried writes collapse to one row. +appendJournalEntry :: (IOE :> es, Store :> es) => WorkflowName -> WorkflowId -> WorkflowJournalEvent -> Eff es () +appendJournalEntry name wid event = void (appendJournalEntryReturningId name wid event) + +-- | Like 'appendJournalEntry' but returns the (deterministic) 'EventId' of +-- the entry. EP-39's fired timer needs this for @markTimerFired@. +appendJournalEntryReturningId :: (IOE :> es, Store :> es) => WorkflowName -> WorkflowId -> WorkflowJournalEvent -> Eff es EventId +appendJournalEntryReturningId name wid event = do + -- EP-48: a wake source (timer fired, signalAwakeable, child completion) + -- resolves the awaited step on whichever generation the suspended run is + -- parked on — always the current (highest) one, since runs only ever operate + -- on the current generation. Resolve it here so the append and its + -- deterministic id are namespaced by that generation. + gen <- currentGeneration name wid + let key = journalKey event + entryId = deterministicJournalId name wid gen key + appendJournal name wid gen event >>= \case + JournalAppended {} -> pure entryId + JournalAlreadyPresent {} -> pure entryId + JournalAppendConflict err -> throwIO (WorkflowJournalAppendError (Text.pack (show err))) + +-- | Append a journal entry only if it is not already journaled, returning the +-- 'AppendResult' of the fresh append (or 'Nothing' if it already existed). Used +-- on the completion path so a terminal ('OnTerminal') snapshot can be taken from +-- the completing run's 'AppendResult', while a replay of an already-completed +-- workflow is a no-op. +appendCompletion :: (IOE :> es, Store :> es) => WorkflowName -> WorkflowId -> Int -> UTCTime -> Eff es (Maybe AppendResult) +appendCompletion name wid gen now = do + appendJournal name wid gen (WorkflowCompleted now) >>= \case + JournalAppended appendResult -> pure (Just appendResult) + JournalAlreadyPresent {} -> pure Nothing + JournalAppendConflict err -> throwIO (WorkflowJournalAppendError (Text.pack (show err))) + +-- | Perform a continue-as-new rotation (EP-48): close generation @gen@ and open +-- generation @gen + 1@, seeded with @seedJson@ and the deployed patch set. Returns +-- 'ContinuedAsNew'. +-- +-- The next generation's seed and non-empty patch set are appended in one +-- transaction before the old generation's rotation marker. The seed advances +-- @MAX(generation)@ — and therefore 'currentGeneration' — to @gen + 1@, while the +-- same commit makes patch decisions available before any asynchronous wake writer +-- can append to the new generation. After that commit, any re-run resolves the +-- current generation to @gen + 1@, hydrates from the seed and patch set, and never +-- re-enters generation @gen@. We then append the terminal +-- 'WorkflowContinuedAsNew' marker on generation @gen@. Every append is guarded by +-- an existence check and uses a deterministic, generation-namespaced id, so the +-- whole rotation is idempotent. +-- +-- The seed carries state forward and the patch-set entry freezes code-evolution +-- decisions. We snapshot their map at the newest fresh append's version so the +-- next generation hydrates in O(1). The snapshot is advisory, so it is written +-- unconditionally on rotation regardless of the run's 'snapshotPolicy' — rotation +-- is exactly when a fresh snapshot earns its keep. +rotateGeneration :: + forall a es. + (IOE :> es, Store :> es, Error StoreError :> es) => + Maybe KeiroMetrics -> + Set PatchId -> + WorkflowName -> + WorkflowId -> + Int -> + Aeson.Value -> + Eff es (WorkflowOutcome a) +rotateGeneration mMetrics patches name wid gen seedJson = do + let nextGen = gen + 1 + encodedPatches = Aeson.toJSON (map unPatchId (Set.toList patches)) + patchEvent = + StepRecorded patchSetStepName encodedPatches + now <- liftIO getCurrentTime + seedTx <- + prepareJournalAppend + name + wid + nextGen + (StepRecorded continueSeedStepName seedJson now) + patchTx <- + if Set.null patches + then pure Nothing + else + Just + <$> prepareJournalAppend + name + wid + nextGen + (patchEvent now) + -- 1. Seed and patch set on the NEXT generation in one transaction. A + -- conflict condemns the whole transaction before it returns its diagnostic + -- outcome, so no seed-without-patch intermediate state can commit. + (seedOutcome, patchOutcome) <- + runTransaction $ do + seedResult <- seedTx + condemnOnConflict seedResult + patchResult <- traverse id patchTx + traverse_ condemnOnConflict patchResult + pure (seedResult, patchResult) + throwOnConflict seedOutcome + traverse_ throwOnConflict patchOutcome + let seedValue = recordedValue seedJson seedOutcome + snapshotState = + maybe + (Map.singleton continueSeedStepName seedValue) + ( \outcome -> + Map.fromList + [ (continueSeedStepName, seedValue), + (patchSetStepName, recordedValue encodedPatches outcome) + ] + ) + patchOutcome + snapshotAppend = + case patchOutcome of + Just (JournalAppended appendResult) -> Just appendResult + _ -> case seedOutcome of + JournalAppended appendResult -> Just appendResult + _ -> Nothing + for_ snapshotAppend $ \appendResult -> + writeWorkflowSnapshotAdvisory + mMetrics + (appendResult ^. #streamId) + (appendResult ^. #streamVersion) + snapshotState + -- 2. Terminal rotation marker on the CURRENT generation (audit + closes it). + appendJournal name wid gen (WorkflowContinuedAsNew nextGen now) >>= \case + JournalAppended {} -> pure () + JournalAlreadyPresent {} -> pure () + JournalAppendConflict err -> throwIO (WorkflowJournalAppendError (Text.pack (show err))) + pure ContinuedAsNew + where + condemnOnConflict = \case + JournalAppendConflict {} -> Tx.condemn + _ -> pure () + throwOnConflict = \case + JournalAppendConflict err -> + throwIO (WorkflowJournalAppendError (Text.pack (show err))) + _ -> pure () + recordedValue fallback = \case + JournalAlreadyPresent stored -> stored + _ -> fallback + +-- | Snapshot a workflow state after its journal append has committed. The +-- snapshot is advisory: a store failure is counted and cannot turn the +-- already-durable workflow transition into a failed run. +writeWorkflowSnapshotAdvisory :: + (IOE :> es, Store :> es, Error StoreError :> es) => + Maybe KeiroMetrics -> + StreamId -> + StreamVersion -> + WorkflowState -> + Eff es () +writeWorkflowSnapshotAdvisory mMetrics streamId version state = do + -- WorkflowState is already a Map Text Value assembled from journaled step + -- results, so this path has no aggregate RegFile/uninit encode to guard. + outcome <- tryError @StoreError (writeWorkflowSnapshot streamId version state) + case outcome of + Right () -> pure () + Left _ -> recordSnapshotWriteFailures mMetrics 1 + +instanceStatusForEvent :: WorkflowJournalEvent -> (WorkflowStatus, Maybe Text) +instanceStatusForEvent = \case + StepRecorded {} -> (WfRunning, Nothing) + WorkflowCompleted {} -> (WfCompleted, Nothing) + WorkflowCancelled {} -> (WfCancelled, Nothing) + WorkflowFailed reason _ -> (WfFailed, Just reason) + WorkflowContinuedAsNew {} -> (WfRunning, Nothing) + +-- | The reserved step-name key a journal event indexes under. +journalKey :: WorkflowJournalEvent -> Text +journalKey = \case + StepRecorded {stepName = key} -> key + WorkflowCompleted {} -> completedStepName + WorkflowCancelled {} -> cancelledStepName + WorkflowFailed {} -> failedStepName + WorkflowContinuedAsNew {} -> continuedAsNewStepName + +-- | The index row corresponding to a journal event, on the given generation. +journalRow :: WorkflowName -> WorkflowId -> Int -> WorkflowJournalEvent -> WorkflowStepRow +journalRow name wid gen = \case + StepRecorded key value t -> + WorkflowStepRow + { workflowId = unWorkflowId wid, + workflowName = unWorkflowName name, + generation = gen, + stepName = key, + result = value, + recordedAt = t + } + WorkflowCompleted t -> + WorkflowStepRow + { workflowId = unWorkflowId wid, + workflowName = unWorkflowName name, + generation = gen, + stepName = completedStepName, + result = Aeson.Null, + recordedAt = t + } + WorkflowCancelled t -> + WorkflowStepRow + { workflowId = unWorkflowId wid, + workflowName = unWorkflowName name, + generation = gen, + stepName = cancelledStepName, + result = Aeson.Null, + recordedAt = t + } + WorkflowFailed r t -> + WorkflowStepRow + { workflowId = unWorkflowId wid, + workflowName = unWorkflowName name, + generation = gen, + stepName = failedStepName, + result = Aeson.toJSON r, + recordedAt = t + } + WorkflowContinuedAsNew g t -> + WorkflowStepRow + { workflowId = unWorkflowId wid, + workflowName = unWorkflowName name, + generation = gen, + stepName = continuedAsNewStepName, + result = Aeson.toJSON g, -- the NEXT generation this rotation opens + recordedAt = t + } + +-- | A stable, collision-resistant journal-event id from +-- @("keiro" : "workflow" : name : id : generation : stepName)@ via a v5 UUID. +-- Mirrors 'Keiro.ProcessManager.deterministicCommandId': the same inputs always +-- yield the same id, so a re-append of the same step collapses to the same row. +-- +-- The /generation/ (EP-48) is part of the id so a step named @"s1"@ in +-- generation 0 and the same name in generation 1 produce __different__ kiroku +-- event ids — they live on different physical streams, but the event id is +-- global, so namespacing it by generation keeps rotated generations from +-- colliding on the deterministic id. +deterministicJournalId :: WorkflowName -> WorkflowId -> Int -> Text -> EventId +deterministicJournalId (WorkflowName name) (WorkflowId wid) gen key = + EventId $ + UUID.V5.generateNamed UUID.V5.namespaceURL $ + fmap (fromIntegral . fromEnum) $ + Text.unpack $ + Text.intercalate ":" ["keiro", "workflow", name, wid, Text.pack (show gen), key] diff --git a/src/Keiro/Workflow/Awakeable.hs b/src/Keiro/Workflow/Awakeable.hs --- a/src/Keiro/Workflow/Awakeable.hs +++ b/src/Keiro/Workflow/Awakeable.hs @@ -1,57 +1,56 @@ -{- | Awakeables: durable promises an external system resolves. - -== What this gives you - -A workflow allocates an opaque 'AwakeableId', hands it to some external system -(a webhook handler, a human approver, an LLM tool call), and suspends until -that system /signals/ the id with a result — no polling, no bespoke -"wait for event X then react in a process manager" wiring. - -@ -approvalFlow :: ('Workflow' ':>' es, 'Store' ':>' es, 'IOE' ':>' es) => Eff es Text -approvalFlow = do - (aid, await) <- 'awakeableNamed' (StepName \"approval\") -- allocate the promise - -- (hand @aid@ to a webhook handler / human / LLM tool here) - decision <- await -- SUSPEND until signalled - 'Keiro.Workflow.step' (StepName \"use\") (pure (decision <> \"!\")) -@ - -The @pending@ row is committed as part of the journaled allocation step, -before the id can be returned or handed to an external system. On the __first__ -'Keiro.Workflow.runWorkflow' this returns 'Suspended' (the run parked on -@await@). An external caller later runs -@'signalAwakeable' aid \"ok\"@, which flips the row to @completed@ /and/ -appends a @StepRecorded \"awk:\\"@ 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. A signal that loses a row race to - cancellation returns 'False' without appending. -* 'cancelAwakeable' abandons a still-@pending@ promise; a workflow that - re-enters its @await@ then throws 'WorkflowAwakeableCancelled', which the - author can @catch@ for compensation. If uncaught, EP-42's resume worker - records an attempt, backs off, and eventually appends 'WorkflowFailed' at the - configured failure ceiling. -* @countPendingAwakeables@ (in "Keiro.Workflow.Awakeable.Schema") backs EP-44's - @keiro.workflow.awakeables.pending@ gauge. --} -module Keiro.Workflow.Awakeable ( - -- * Awakeable ids +-- | Awakeables: durable promises an external system resolves. +-- +-- == What this gives you +-- +-- A workflow allocates an opaque 'AwakeableId', hands it to some external system +-- (a webhook handler, a human approver, an LLM tool call), and suspends until +-- that system /signals/ the id with a result — no polling, no bespoke +-- "wait for event X then react in a process manager" wiring. +-- +-- @ +-- approvalFlow :: ('Workflow' ':>' es, 'Store' ':>' es, 'IOE' ':>' es) => Eff es Text +-- approvalFlow = do +-- (aid, await) <- 'awakeableNamed' (StepName \"approval\") -- allocate the promise +-- -- (hand @aid@ to a webhook handler / human / LLM tool here) +-- decision <- await -- SUSPEND until signalled +-- 'Keiro.Workflow.step' (StepName \"use\") (pure (decision <> \"!\")) +-- @ +-- +-- The @pending@ row is committed as part of the journaled allocation step, +-- before the id can be returned or handed to an external system. On the __first__ +-- 'Keiro.Workflow.runWorkflow' this returns 'Suspended' (the run parked on +-- @await@). An external caller later runs +-- @'signalAwakeable' aid \"ok\"@, which flips the row to @completed@ /and/ +-- appends a @StepRecorded \"awk:\\"@ 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. A signal that loses a row race to +-- cancellation returns 'False' without appending. +-- * 'cancelAwakeable' abandons a still-@pending@ promise; a workflow that +-- re-enters its @await@ then throws 'WorkflowAwakeableCancelled', which the +-- author can @catch@ for compensation. If uncaught, EP-42's resume worker +-- records an attempt, backs off, and eventually appends 'WorkflowFailed' at the +-- configured failure ceiling. +-- * @countPendingAwakeables@ (in "Keiro.Workflow.Awakeable.Schema") backs EP-44's +-- @keiro.workflow.awakeables.pending@ gauge. +module Keiro.Workflow.Awakeable + ( -- * Awakeable ids AwakeableId (..), awakeableIdToUuid, awakeableIdText, @@ -68,7 +67,7 @@ -- * Errors WorkflowAwakeableCancelled (..), -) + ) where import Control.Exception (Exception) @@ -80,8 +79,8 @@ import Effectful (Eff, IOE, (:>)) import Effectful.Exception (throwIO) import Keiro.Prelude -import Keiro.Workflow ( - JournalAppendOutcome (..), +import Keiro.Workflow + ( JournalAppendOutcome (..), StepName (..), Workflow, WorkflowError (..), @@ -98,16 +97,16 @@ freshOrdinal, prepareJournalAppend, step, - ) -import Keiro.Workflow.Awakeable.Schema ( - AwakeableRow, + ) +import Keiro.Workflow.Awakeable.Schema + ( AwakeableRow, AwakeableStatus (..), cancelAwakeableTx, completeAwakeableTx, lookupAwakeable, lookupAwakeableStatusTx, registerAwakeableTx, - ) + ) import Kiroku.Store.Effect (Store) import Kiroku.Store.Transaction (runTransaction) import "hasql-transaction" Hasql.Transaction qualified as Tx @@ -116,55 +115,51 @@ -- Awakeable ids -- --------------------------------------------------------------------------- -{- | The opaque id of an awakeable. New allocations are random and journaled by -'awakeableNamed'; 'deterministicAwakeableId' is retained only as a legacy -generation-0 adoption helper. The @ToJSON@\/@FromJSON@ instances are over the -inner UUID, so the workflow journal can replay the id and webhook payloads may -carry it. --} +-- | The opaque id of an awakeable. New allocations are random and journaled by +-- 'awakeableNamed'; 'deterministicAwakeableId' is retained only as a legacy +-- generation-0 adoption helper. The @ToJSON@\/@FromJSON@ instances are over the +-- inner UUID, so the workflow journal can replay the id and webhook payloads may +-- carry it. newtype AwakeableId = AwakeableId UUID - deriving stock (Eq, Show, Generic) - deriving newtype (ToJSON, FromJSON) + deriving stock (Eq, Show, Generic) + deriving newtype (ToJSON, FromJSON) -- | The raw UUID inside an 'AwakeableId'. awakeableIdToUuid :: AwakeableId -> UUID awakeableIdToUuid (AwakeableId u) = u -{- | The 'AwakeableId' rendered as text — the suffix of the @awk:\@ -journal step name an awakeable's completion is recorded under. --} +-- | 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. --} +-- | The legacy deterministic 'AwakeableId' for a @(workflow name, workflow id, +-- label)@: a v5 UUID over @(\"keiro\":\"awakeable\":name:id:label)@. +-- +-- This is predictable from public coordinates, so new code must not hand-derive +-- ids with it. It remains exported for operators and for generation-0 adoption: +-- if a pre-change workflow already registered a row under this id, the first +-- post-change allocation adopts that row so the in-flight promise keeps working. deterministicAwakeableId :: WorkflowName -> WorkflowId -> Text -> AwakeableId deterministicAwakeableId (WorkflowName name) (WorkflowId wid) label = - AwakeableId $ - UUID.V5.generateNamed UUID.V5.namespaceURL $ - fmap (fromIntegral . fromEnum) $ - Text.unpack $ - Text.intercalate ":" ["keiro", "awakeable", name, wid, label] + AwakeableId $ + UUID.V5.generateNamed UUID.V5.namespaceURL $ + fmap (fromIntegral . fromEnum) $ + Text.unpack $ + Text.intercalate ":" ["keiro", "awakeable", name, wid, label] -- --------------------------------------------------------------------------- -- Errors -- --------------------------------------------------------------------------- -{- | Thrown out of 'Keiro.Workflow.runWorkflow' when a workflow re-enters the -@await@ of an awakeable that was 'cancelAwakeable'd. A cancelled awakeable will -never be signalled, so suspending forever would be wrong and silently -completing would fabricate a result; the workflow author can @catch@ this to -run compensation. If uncaught, the resume worker records the attempt and -eventually marks the workflow failed at its configured ceiling. --} +-- | Thrown out of 'Keiro.Workflow.runWorkflow' when a workflow re-enters the +-- @await@ of an awakeable that was 'cancelAwakeable'd. A cancelled awakeable will +-- never be signalled, so suspending forever would be wrong and silently +-- completing would fabricate a result; the workflow author can @catch@ this to +-- run compensation. If uncaught, the resume worker records the attempt and +-- eventually marks the workflow failed at its configured ceiling. newtype WorkflowAwakeableCancelled = WorkflowAwakeableCancelled AwakeableId - deriving stock (Eq, Show) + deriving stock (Eq, Show) instance Exception WorkflowAwakeableCancelled @@ -172,210 +167,203 @@ -- Authoring surface -- --------------------------------------------------------------------------- -{- | Allocate an awakeable under the stable, caller-supplied @label@. Returns -the 'AwakeableId' (hand it to the external system) and an @await@ action that -'Suspended's the workflow until the awakeable is signalled, then yields the -decoded payload on a later run. - -The @label@ is the only fully-deterministic option: it survives code edits that -insert or remove awakeables elsewhere in the workflow (the same robustness -argument EP-38 makes for named steps over positional history). Prefer this over -'awakeable' for anything that may outlive a code change mid-flight. --} +-- | Allocate an awakeable under the stable, caller-supplied @label@. Returns +-- the 'AwakeableId' (hand it to the external system) and an @await@ action that +-- 'Suspended's the workflow until the awakeable is signalled, then yields the +-- decoded payload on a later run. +-- +-- The @label@ is the only fully-deterministic option: it survives code edits that +-- insert or remove awakeables elsewhere in the workflow (the same robustness +-- argument EP-38 makes for named steps over positional history). Prefer this over +-- 'awakeable' for anything that may outlive a code change mid-flight. awakeableNamed :: - (Workflow :> es, Store :> es, IOE :> es, FromJSON a) => - StepName -> - Eff es (AwakeableId, Eff es a) + (Workflow :> es, Store :> es, IOE :> es, FromJSON a) => + StepName -> + Eff es (AwakeableId, Eff es a) awakeableNamed (StepName label) = do - (name, wid) <- currentWorkflow - gen <- currentRunGeneration - aid <- - step (StepName (awakeableAllocStepPrefix <> label)) $ do - allocated <- allocateAwakeableId name wid gen label - runTransaction $ - registerAwakeableTx - (awakeableIdToUuid allocated) - (unWorkflowName name) - (unWorkflowId wid) - pure allocated - let - stepNm = StepName (awakeableStepPrefix <> awakeableIdText aid) - await = awaitCancellable name wid aid stepNm - pure (aid, await) + (name, wid) <- currentWorkflow + gen <- currentRunGeneration + aid <- + step (StepName (awakeableAllocStepPrefix <> label)) $ do + allocated <- allocateAwakeableId name wid gen label + runTransaction $ + registerAwakeableTx + (awakeableIdToUuid allocated) + (unWorkflowName name) + (unWorkflowId wid) + pure allocated + let stepNm = StepName (awakeableStepPrefix <> awakeableIdText aid) + await = awaitCancellable name wid aid stepNm + pure (aid, await) allocateAwakeableId :: - (Store :> es, IOE :> es) => - WorkflowName -> - WorkflowId -> - Int -> - Text -> - Eff es AwakeableId + (Store :> es, IOE :> es) => + WorkflowName -> + WorkflowId -> + Int -> + Text -> + Eff es AwakeableId allocateAwakeableId name wid gen label - | gen <= 0 = do - let legacy = deterministicAwakeableId name wid label - existing <- lookupAwakeable (awakeableIdToUuid legacy) - case existing of - Just _ -> pure legacy - Nothing -> AwakeableId <$> liftIO UUID.V4.nextRandom - | otherwise = AwakeableId <$> liftIO UUID.V4.nextRandom + | gen <= 0 = do + let legacy = deterministicAwakeableId name wid label + existing <- lookupAwakeable (awakeableIdToUuid legacy) + case existing of + Just _ -> pure legacy + Nothing -> AwakeableId <$> liftIO UUID.V4.nextRandom + | otherwise = AwakeableId <$> liftIO UUID.V4.nextRandom -{- | Allocate an awakeable under an ordinal label (the @N@th awakeable in a run -becomes @ord:N@). Convenient, but its determinism is __conditional__: adding or -removing an 'awakeable' call earlier in the workflow shifts every later ordinal -and so changes their derived ids, which corrupts an in-flight workflow exactly -the way EP-38 warns positional history does. Prefer 'awakeableNamed' for -anything that may outlive a code edit. --} +-- | Allocate an awakeable under an ordinal label (the @N@th awakeable in a run +-- becomes @ord:N@). Convenient, but its determinism is __conditional__: adding or +-- removing an 'awakeable' call earlier in the workflow shifts every later ordinal +-- and so changes their derived ids, which corrupts an in-flight workflow exactly +-- the way EP-38 warns positional history does. Prefer 'awakeableNamed' for +-- anything that may outlive a code edit. awakeable :: - (Workflow :> es, Store :> es, IOE :> es, FromJSON a) => - Eff es (AwakeableId, Eff es a) + (Workflow :> es, Store :> es, IOE :> es, FromJSON a) => + Eff es (AwakeableId, Eff es a) awakeable = do - n <- freshOrdinal awakeableStepPrefix - awakeableNamed (StepName ("ord:" <> Text.pack (show n))) + n <- freshOrdinal awakeableStepPrefix + awakeableNamed (StepName ("ord:" <> Text.pack (show n))) -{- | EP-38's 'awaitStep', wrapped so that a re-entered @await@ on a -'Cancelled' awakeable throws 'WorkflowAwakeableCancelled' instead of suspending -forever. The check lives /inside/ the arming action because 'awaitStep' runs -@arm@ only on the miss path (the awakeable not yet journaled) and re-runs it on -every resume until it resolves: on a miss we either notice the cancel and throw, -or (re-)register the idempotent @pending@ row and suspend. On the hit path -('signalAwakeable' already journaled the result) @arm@ is never run, so a -signalled-then-cancelled race still returns the signalled value (signal wins — a -resolved promise cannot be un-resolved). --} +-- | EP-38's 'awaitStep', wrapped so that a re-entered @await@ on a +-- 'Cancelled' awakeable throws 'WorkflowAwakeableCancelled' instead of suspending +-- forever. The check lives /inside/ the arming action because 'awaitStep' runs +-- @arm@ only on the miss path (the awakeable not yet journaled) and re-runs it on +-- every resume until it resolves: on a miss we either notice the cancel and throw, +-- or (re-)register the idempotent @pending@ row and suspend. On the hit path +-- ('signalAwakeable' already journaled the result) @arm@ is never run, so a +-- signalled-then-cancelled race still returns the signalled value (signal wins — a +-- resolved promise cannot be un-resolved). awaitCancellable :: - (Workflow :> es, Store :> es, IOE :> es, FromJSON a) => - WorkflowName -> WorkflowId -> AwakeableId -> StepName -> Eff es a + (Workflow :> es, Store :> es, IOE :> es, FromJSON a) => + WorkflowName -> WorkflowId -> AwakeableId -> StepName -> Eff es a awaitCancellable name wid aid stepNm = - awaitStep stepNm $ do - existing <- lookupAwakeable (awakeableIdToUuid aid) - case existing of - Just row - | row ^. #status == Cancelled -> - throwIO (WorkflowAwakeableCancelled aid) - | row ^. #status == Completed - , Just payload <- row ^. #payload -> do - now <- liftIO getCurrentTime - appendJournalEntry - name - wid - StepRecorded - { stepName = unStepName stepNm - , result = payload - , recordedAt = now - } - _ -> - runTransaction $ - registerAwakeableTx (awakeableIdToUuid aid) (unWorkflowName name) (unWorkflowId wid) + awaitStep stepNm $ do + existing <- lookupAwakeable (awakeableIdToUuid aid) + case existing of + Just row + | row ^. #status == Cancelled -> + throwIO (WorkflowAwakeableCancelled aid) + | row ^. #status == Completed, + Just payload <- row ^. #payload -> do + now <- liftIO getCurrentTime + appendJournalEntry + name + wid + StepRecorded + { stepName = unStepName stepNm, + result = payload, + recordedAt = now + } + _ -> + runTransaction $ + registerAwakeableTx (awakeableIdToUuid aid) (unWorkflowName name) (unWorkflowId wid) -- --------------------------------------------------------------------------- -- External completion -- --------------------------------------------------------------------------- -{- | Resolve an awakeable from outside the workflow: store @result@ in the -@keiro_awakeables@ row /and/ append a @StepRecorded@ to the owning workflow's -journal so the next run replays past the @await@. - -Idempotent and crash-safe: - -* Returns 'True' only when /this/ call transitioned the row @pending@ -> - @completed@; a second signal (or a signal of a @cancelled@ row) returns - 'False' and leaves the stored payload unchanged. -* For a @pending@ row, the row transition and journal append happen in one - transaction. For an already-@completed@ row, the journal entry is re-appended - from the stored payload to repair rows wedged before that atomic path existed. - The append path is idempotent (deterministic event id plus step-index check), - so a re-append collapses to a no-op once the entry is present. -* If a cancellation wins after this function's initial row read but before its - guarded completion, the transaction re-reads the status and appends nothing. - The signal returns 'False', so cancellation cannot both trigger compensation - and leak a completion value into the workflow journal. - -A 'False' return therefore does not mean "nothing happened": the journal may -still have been repaired. Returns 'False' for an unknown id. --} +-- | Resolve an awakeable from outside the workflow: store @result@ in the +-- @keiro_awakeables@ row /and/ append a @StepRecorded@ to the owning workflow's +-- journal so the next run replays past the @await@. +-- +-- Idempotent and crash-safe: +-- +-- * Returns 'True' only when /this/ call transitioned the row @pending@ -> +-- @completed@; a second signal (or a signal of a @cancelled@ row) returns +-- 'False' and leaves the stored payload unchanged. +-- * For a @pending@ row, the row transition and journal append happen in one +-- transaction. For an already-@completed@ row, the journal entry is re-appended +-- from the stored payload to repair rows wedged before that atomic path existed. +-- The append path is idempotent (deterministic event id plus step-index check), +-- so a re-append collapses to a no-op once the entry is present. +-- * If a cancellation wins after this function's initial row read but before its +-- guarded completion, the transaction re-reads the status and appends nothing. +-- The signal returns 'False', so cancellation cannot both trigger compensation +-- and leak a completion value into the workflow journal. +-- +-- A 'False' return therefore does not mean "nothing happened": the journal may +-- still have been repaired. Returns 'False' for an unknown id. signalAwakeable :: (IOE :> es, Store :> es, ToJSON r) => AwakeableId -> r -> Eff es Bool signalAwakeable aid result = - lookupAwakeable (awakeableIdToUuid aid) >>= \case - Nothing -> pure False - Just row -> signalAwakeableFrom row result - -{- | The transaction-decision core of 'signalAwakeable', exposed so race -contracts can deterministically interpose between the initial row read and the -guarded completion. Normal callers should use 'signalAwakeable'. + lookupAwakeable (awakeableIdToUuid aid) >>= \case + Nothing -> pure False + Just row -> signalAwakeableFrom row result -The supplied row may be stale. This function therefore trusts it only for the -owner coordinates and candidate payload; when a pending-to-completed UPDATE -loses, it re-reads status inside the same transaction and appends only if -another signal completed the row. A winning cancellation gets no append. --} +-- | The transaction-decision core of 'signalAwakeable', exposed so race +-- contracts can deterministically interpose between the initial row read and the +-- guarded completion. Normal callers should use 'signalAwakeable'. +-- +-- The supplied row may be stale. This function therefore trusts it only for the +-- owner coordinates and candidate payload; when a pending-to-completed UPDATE +-- loses, it re-reads status inside the same transaction and appends only if +-- another signal completed the row. A winning cancellation gets no append. signalAwakeableFrom :: - (IOE :> es, Store :> es, ToJSON r) => - AwakeableRow -> - r -> - Eff es Bool + (IOE :> es, Store :> es, ToJSON r) => + AwakeableRow -> + r -> + Eff es Bool signalAwakeableFrom row result - | row ^. #status == Cancelled = pure False - | otherwise = do - now <- liftIO getCurrentTime - let aid = AwakeableId (row ^. #awakeableId) - payload = - if row ^. #status == Completed - then row ^. #payload - else Just (toJSON result) - case payload of - Nothing -> pure False - Just payloadValue -> do - let ownerName = WorkflowName (row ^. #ownerWorkflowName) - ownerId = WorkflowId (row ^. #ownerWorkflowId) - gen <- currentGeneration ownerName ownerId - appendTx <- - prepareJournalAppend - ownerName - ownerId - gen - StepRecorded - { stepName = awakeableStepPrefix <> awakeableIdText aid - , result = payloadValue - , recordedAt = now - } - (transitioned, appendOutcome) <- - runTransaction $ do - transitioned <- - if row ^. #status == Pending - then completeAwakeableTx (awakeableIdToUuid aid) (toJSON result) now - else pure False - if transitioned || row ^. #status == Completed - then do - outcome <- appendTx - condemnOnAppendConflict outcome - pure (transitioned, Just outcome) - else - lookupAwakeableStatusTx (awakeableIdToUuid aid) >>= \case - Just Completed -> do - outcome <- appendTx - condemnOnAppendConflict outcome - pure (False, Just outcome) - _ -> pure (False, Nothing) - for_ appendOutcome throwOnAppendConflict - pure transitioned + | row ^. #status == Cancelled = pure False + | otherwise = do + now <- liftIO getCurrentTime + let aid = AwakeableId (row ^. #awakeableId) + payload = + if row ^. #status == Completed + then row ^. #payload + else Just (toJSON result) + case payload of + Nothing -> pure False + Just payloadValue -> do + let ownerName = WorkflowName (row ^. #ownerWorkflowName) + ownerId = WorkflowId (row ^. #ownerWorkflowId) + gen <- currentGeneration ownerName ownerId + appendTx <- + prepareJournalAppend + ownerName + ownerId + gen + StepRecorded + { stepName = awakeableStepPrefix <> awakeableIdText aid, + result = payloadValue, + recordedAt = now + } + (transitioned, appendOutcome) <- + runTransaction $ do + transitioned <- + if row ^. #status == Pending + then completeAwakeableTx (awakeableIdToUuid aid) (toJSON result) now + else pure False + if transitioned || row ^. #status == Completed + then do + outcome <- appendTx + condemnOnAppendConflict outcome + pure (transitioned, Just outcome) + else + lookupAwakeableStatusTx (awakeableIdToUuid aid) >>= \case + Just Completed -> do + outcome <- appendTx + condemnOnAppendConflict outcome + pure (False, Just outcome) + _ -> pure (False, Nothing) + for_ appendOutcome throwOnAppendConflict + pure transitioned condemnOnAppendConflict :: JournalAppendOutcome -> Tx.Transaction () condemnOnAppendConflict = \case - JournalAppendConflict{} -> Tx.condemn - _ -> pure () + JournalAppendConflict {} -> Tx.condemn + _ -> pure () throwOnAppendConflict :: JournalAppendOutcome -> Eff es () throwOnAppendConflict = \case - JournalAppendConflict err -> throwIO (WorkflowJournalAppendError (Text.pack (show err))) - _ -> pure () + JournalAppendConflict err -> throwIO (WorkflowJournalAppendError (Text.pack (show err))) + _ -> pure () -{- | Abandon a still-@pending@ awakeable: flips its row to @cancelled@ and -writes __no__ journal entry (there is no result value to record). Returns 'True' -when it transitioned a @pending@ row, 'False' otherwise (already completed, -already cancelled, or unknown). A workflow that later re-enters the awakeable's -@await@ then throws 'WorkflowAwakeableCancelled'. --} +-- | Abandon a still-@pending@ awakeable: flips its row to @cancelled@ and +-- writes __no__ journal entry (there is no result value to record). Returns 'True' +-- when it transitioned a @pending@ row, 'False' otherwise (already completed, +-- already cancelled, or unknown). A workflow that later re-enters the awakeable's +-- @await@ then throws 'WorkflowAwakeableCancelled'. cancelAwakeable :: (Store :> es) => AwakeableId -> Eff es Bool cancelAwakeable aid = - runTransaction $ cancelAwakeableTx (awakeableIdToUuid aid) + runTransaction $ cancelAwakeableTx (awakeableIdToUuid aid) diff --git a/src/Keiro/Workflow/Awakeable/Schema.hs b/src/Keiro/Workflow/Awakeable/Schema.hs --- a/src/Keiro/Workflow/Awakeable/Schema.hs +++ b/src/Keiro/Workflow/Awakeable/Schema.hs @@ -1,25 +1,24 @@ -{- | The @keiro_awakeables@ table: durable storage for awakeables (external -promises a workflow suspends on). - -Mirrors the @Keiro.Timer@ \/ @Keiro.Timer.Schema@ split: this module owns the -row type, the 'AwakeableStatus' lifecycle, and the hasql statements; -"Keiro.Workflow.Awakeable" owns the effectful authoring\/completion surface. - -* 'registerAwakeableTx' inserts a @pending@ row idempotently (the - @ON CONFLICT DO NOTHING@ EP-38's @awaitStep@ arming contract requires). -* 'lookupAwakeable' reads a row back. -* 'completeAwakeableTx' transitions a @pending@ row to @completed@ (guarded so - a double signal is a no-op), and 'cancelAwakeableTx' transitions it to - @cancelled@. -* 'countPendingAwakeables' counts outstanding promises — the seam EP-44 reads - for its @keiro.workflow.awakeables.pending@ gauge. - -Callers normally use the re-exports / surface from "Keiro.Workflow.Awakeable" -rather than this module directly; EP-44 imports 'countPendingAwakeables' here -without pulling in the effect surface. --} -module Keiro.Workflow.Awakeable.Schema ( - -- * Rows and status +-- | The @keiro_awakeables@ table: durable storage for awakeables (external +-- promises a workflow suspends on). +-- +-- Mirrors the @Keiro.Timer@ \/ @Keiro.Timer.Schema@ split: this module owns the +-- row type, the 'AwakeableStatus' lifecycle, and the hasql statements; +-- "Keiro.Workflow.Awakeable" owns the effectful authoring\/completion surface. +-- +-- * 'registerAwakeableTx' inserts a @pending@ row idempotently (the +-- @ON CONFLICT DO NOTHING@ EP-38's @awaitStep@ arming contract requires). +-- * 'lookupAwakeable' reads a row back. +-- * 'completeAwakeableTx' transitions a @pending@ row to @completed@ (guarded so +-- a double signal is a no-op), and 'cancelAwakeableTx' transitions it to +-- @cancelled@. +-- * 'countPendingAwakeables' counts outstanding promises — the seam EP-44 reads +-- for its @keiro.workflow.awakeables.pending@ gauge. +-- +-- Callers normally use the re-exports / surface from "Keiro.Workflow.Awakeable" +-- rather than this module directly; EP-44 imports 'countPendingAwakeables' here +-- without pulling in the effect surface. +module Keiro.Workflow.Awakeable.Schema + ( -- * Rows and status AwakeableStatus (..), AwakeableRow (..), statusToText, @@ -34,7 +33,7 @@ -- * Read-only lookups lookupAwakeable, countPendingAwakeables, -) + ) where import Contravariant.Extras (contrazip3) @@ -48,187 +47,180 @@ import Kiroku.Store.Transaction (runTransaction) import "hasql-transaction" Hasql.Transaction qualified as Tx -{- | An awakeable's lifecycle state. - -* 'Pending' — allocated and waiting for an external signal; the workflow is - suspended on it. -* 'Completed' — signalled with a payload; terminal. -* 'Cancelled' — abandoned before it was signalled; terminal; also the decode - fallback for an unrecognized stored value (the same defensive choice - "Keiro.Timer.Schema" makes). --} +-- | An awakeable's lifecycle state. +-- +-- * 'Pending' — allocated and waiting for an external signal; the workflow is +-- suspended on it. +-- * 'Completed' — signalled with a payload; terminal. +-- * 'Cancelled' — abandoned before it was signalled; terminal; also the decode +-- fallback for an unrecognized stored value (the same defensive choice +-- "Keiro.Timer.Schema" makes). data AwakeableStatus - = Pending - | Completed - | Cancelled - deriving stock (Generic, Eq, Show) + = Pending + | Completed + | Cancelled + deriving stock (Generic, Eq, Show) -{- | An awakeable row as stored: the deterministic id, the owning workflow's -name and instance id, the live 'status', the signalled 'payload' (JSON, set -only once 'Completed'), and the timestamps. --} +-- | An awakeable row as stored: the deterministic id, the owning workflow's +-- name and instance id, the live 'status', the signalled 'payload' (JSON, set +-- only once 'Completed'), and the timestamps. data AwakeableRow = AwakeableRow - { awakeableId :: !UUID - , ownerWorkflowName :: !Text - , ownerWorkflowId :: !Text - , status :: !AwakeableStatus - , payload :: !(Maybe Value) - , createdAt :: !UTCTime - , updatedAt :: !UTCTime - , completedAt :: !(Maybe UTCTime) - } - deriving stock (Generic, Eq, Show) + { awakeableId :: !UUID, + ownerWorkflowName :: !Text, + ownerWorkflowId :: !Text, + status :: !AwakeableStatus, + payload :: !(Maybe Value), + createdAt :: !UTCTime, + updatedAt :: !UTCTime, + completedAt :: !(Maybe UTCTime) + } + deriving stock (Generic, Eq, Show) -{- | Insert a @pending@ awakeable row inside the caller's transaction. -Idempotent by @ON CONFLICT (awakeable_id) DO NOTHING@ — exactly what EP-38's -"arm must be idempotent" contract needs, since a resumed workflow re-runs the -arming action on every resume until the awakeable resolves. --} +-- | Insert a @pending@ awakeable row inside the caller's transaction. +-- Idempotent by @ON CONFLICT (awakeable_id) DO NOTHING@ — exactly what EP-38's +-- "arm must be idempotent" contract needs, since a resumed workflow re-runs the +-- arming action on every resume until the awakeable resolves. registerAwakeableTx :: UUID -> Text -> Text -> Tx.Transaction () registerAwakeableTx aid name wid = - Tx.statement (aid, name, wid) registerAwakeableStmt + Tx.statement (aid, name, wid) registerAwakeableStmt -{- | Transition a @pending@ awakeable to @completed@, storing @payload@ and the -completion time, inside the caller's transaction. The @status = 'pending'@ -guard makes a double-signal a no-op; returns 'True' only when this call -performed the transition (so the caller knows whether it was the one that -resolved the promise). --} +-- | Transition a @pending@ awakeable to @completed@, storing @payload@ and the +-- completion time, inside the caller's transaction. The @status = 'pending'@ +-- guard makes a double-signal a no-op; returns 'True' only when this call +-- performed the transition (so the caller knows whether it was the one that +-- resolved the promise). completeAwakeableTx :: UUID -> Value -> UTCTime -> Tx.Transaction Bool completeAwakeableTx aid result now = - Tx.statement (aid, result, now) completeAwakeableStmt + Tx.statement (aid, result, now) completeAwakeableStmt -{- | Transition a @pending@ awakeable to @cancelled@ inside the caller's -transaction. Only @pending@ rows match, so an already-completed (or -already-cancelled) awakeable is left untouched and the call returns 'False'. --} +-- | Transition a @pending@ awakeable to @cancelled@ inside the caller's +-- transaction. Only @pending@ rows match, so an already-completed (or +-- already-cancelled) awakeable is left untouched and the call returns 'False'. cancelAwakeableTx :: UUID -> Tx.Transaction Bool cancelAwakeableTx aid = - Tx.statement aid cancelAwakeableStmt + Tx.statement aid cancelAwakeableStmt -{- | Read an awakeable's current status inside the caller's transaction. -Used after a guarded completion loses a row race, so the caller can distinguish -a winning cancel (no journal append) from a winning signal (idempotent repair). --} +-- | Read an awakeable's current status inside the caller's transaction. +-- Used after a guarded completion loses a row race, so the caller can distinguish +-- a winning cancel (no journal append) from a winning signal (idempotent repair). lookupAwakeableStatusTx :: UUID -> Tx.Transaction (Maybe AwakeableStatus) lookupAwakeableStatusTx aid = - Tx.statement aid lookupAwakeableStatusStmt + Tx.statement aid lookupAwakeableStatusStmt -- | Read an awakeable row by id. 'Nothing' if no such awakeable exists. lookupAwakeable :: (Store :> es) => UUID -> Eff es (Maybe AwakeableRow) lookupAwakeable aid = - runTransaction (Tx.statement aid lookupAwakeableStmt) + runTransaction (Tx.statement aid lookupAwakeableStmt) -{- | Count awakeables currently @pending@. Read-only. EP-44 backs the -@keiro.workflow.awakeables.pending@ gauge with this. --} +-- | Count awakeables currently @pending@. Read-only. EP-44 backs the +-- @keiro.workflow.awakeables.pending@ gauge with this. countPendingAwakeables :: (Store :> es) => Eff es Int countPendingAwakeables = - runTransaction (Tx.statement () countPendingAwakeablesStmt) + runTransaction (Tx.statement () countPendingAwakeablesStmt) registerAwakeableStmt :: Statement (UUID, Text, Text) () registerAwakeableStmt = - preparable - """ - INSERT INTO keiro.keiro_awakeables - (awakeable_id, owner_workflow_name, owner_workflow_id, status) - VALUES ($1, $2, $3, 'pending') - ON CONFLICT (awakeable_id) DO NOTHING - """ - ( contrazip3 - (E.param (E.nonNullable E.uuid)) - (E.param (E.nonNullable E.text)) - (E.param (E.nonNullable E.text)) - ) - D.noResult + preparable + """ + INSERT INTO keiro.keiro_awakeables + (awakeable_id, owner_workflow_name, owner_workflow_id, status) + VALUES ($1, $2, $3, 'pending') + ON CONFLICT (awakeable_id) DO NOTHING + """ + ( contrazip3 + (E.param (E.nonNullable E.uuid)) + (E.param (E.nonNullable E.text)) + (E.param (E.nonNullable E.text)) + ) + D.noResult completeAwakeableStmt :: Statement (UUID, Value, UTCTime) Bool completeAwakeableStmt = - preparable - """ - UPDATE keiro.keiro_awakeables - SET status = 'completed', - payload = $2, - completed_at = $3, - updated_at = now() - WHERE awakeable_id = $1 - AND status = 'pending' - """ - ( contrazip3 - (E.param (E.nonNullable E.uuid)) - (E.param (E.nonNullable E.jsonb)) - (E.param (E.nonNullable E.timestamptz)) - ) - ((> 0) <$> D.rowsAffected) + preparable + """ + UPDATE keiro.keiro_awakeables + SET status = 'completed', + payload = $2, + completed_at = $3, + updated_at = now() + WHERE awakeable_id = $1 + AND status = 'pending' + """ + ( contrazip3 + (E.param (E.nonNullable E.uuid)) + (E.param (E.nonNullable E.jsonb)) + (E.param (E.nonNullable E.timestamptz)) + ) + ((> 0) <$> D.rowsAffected) cancelAwakeableStmt :: Statement UUID Bool cancelAwakeableStmt = - preparable - """ - UPDATE keiro.keiro_awakeables - SET status = 'cancelled', - updated_at = now() - WHERE awakeable_id = $1 - AND status = 'pending' - """ - (E.param (E.nonNullable E.uuid)) - ((> 0) <$> D.rowsAffected) + preparable + """ + UPDATE keiro.keiro_awakeables + SET status = 'cancelled', + updated_at = now() + WHERE awakeable_id = $1 + AND status = 'pending' + """ + (E.param (E.nonNullable E.uuid)) + ((> 0) <$> D.rowsAffected) lookupAwakeableStatusStmt :: Statement UUID (Maybe AwakeableStatus) lookupAwakeableStatusStmt = - preparable - """ - SELECT status - FROM keiro.keiro_awakeables - WHERE awakeable_id = $1 - """ - (E.param (E.nonNullable E.uuid)) - (D.rowMaybe (statusFromText <$> D.column (D.nonNullable D.text))) + preparable + """ + SELECT status + FROM keiro.keiro_awakeables + WHERE awakeable_id = $1 + """ + (E.param (E.nonNullable E.uuid)) + (D.rowMaybe (statusFromText <$> D.column (D.nonNullable D.text))) lookupAwakeableStmt :: Statement UUID (Maybe AwakeableRow) lookupAwakeableStmt = - preparable - """ - SELECT awakeable_id, owner_workflow_name, owner_workflow_id, status, - payload, created_at, updated_at, completed_at - FROM keiro.keiro_awakeables - WHERE awakeable_id = $1 - """ - (E.param (E.nonNullable E.uuid)) - (D.rowMaybe awakeableRowDecoder) + preparable + """ + SELECT awakeable_id, owner_workflow_name, owner_workflow_id, status, + payload, created_at, updated_at, completed_at + FROM keiro.keiro_awakeables + WHERE awakeable_id = $1 + """ + (E.param (E.nonNullable E.uuid)) + (D.rowMaybe awakeableRowDecoder) countPendingAwakeablesStmt :: Statement () Int countPendingAwakeablesStmt = - preparable - """ - SELECT count(*) - FROM keiro.keiro_awakeables - WHERE status = 'pending' - """ - E.noParams - (D.singleRow (fromIntegral <$> D.column (D.nonNullable D.int8))) + preparable + """ + SELECT count(*) + FROM keiro.keiro_awakeables + WHERE status = 'pending' + """ + E.noParams + (D.singleRow (fromIntegral <$> D.column (D.nonNullable D.int8))) awakeableRowDecoder :: D.Row AwakeableRow awakeableRowDecoder = - AwakeableRow - <$> D.column (D.nonNullable D.uuid) - <*> D.column (D.nonNullable D.text) - <*> D.column (D.nonNullable D.text) - <*> (statusFromText <$> D.column (D.nonNullable D.text)) - <*> D.column (D.nullable D.jsonb) - <*> D.column (D.nonNullable D.timestamptz) - <*> D.column (D.nonNullable D.timestamptz) - <*> D.column (D.nullable D.timestamptz) + AwakeableRow + <$> D.column (D.nonNullable D.uuid) + <*> D.column (D.nonNullable D.text) + <*> D.column (D.nonNullable D.text) + <*> (statusFromText <$> D.column (D.nonNullable D.text)) + <*> D.column (D.nullable D.jsonb) + <*> D.column (D.nonNullable D.timestamptz) + <*> D.column (D.nonNullable D.timestamptz) + <*> D.column (D.nullable D.timestamptz) statusToText :: AwakeableStatus -> Text statusToText = \case - Pending -> "pending" - Completed -> "completed" - Cancelled -> "cancelled" + Pending -> "pending" + Completed -> "completed" + Cancelled -> "cancelled" statusFromText :: Text -> AwakeableStatus statusFromText = \case - "pending" -> Pending - "completed" -> Completed - "cancelled" -> Cancelled - _ -> Cancelled + "pending" -> Pending + "completed" -> Completed + "cancelled" -> Cancelled + _ -> Cancelled diff --git a/src/Keiro/Workflow/Child.hs b/src/Keiro/Workflow/Child.hs --- a/src/Keiro/Workflow/Child.hs +++ b/src/Keiro/Workflow/Child.hs @@ -1,64 +1,63 @@ -{- | Child workflows: spawn, wait on, and cancel a workflow from inside another. - -== What this gives you - -Fan-out\/fan-in composition of durable workflows. A /parent/ workflow spawns a -/child/ (a second workflow with its own journal stream), waits for the child's -result, and may cancel a child it no longer needs — with the whole relationship -surviving a crash, because the spawn is recorded in the parent's journal and the -link is stored in @keiro_workflow_children@. - -@ -parent :: ('Workflow' ':>' es, 'Store' ':>' es, 'IOE' ':>' es) => Eff es Text -parent = do - h <- 'spawnChild' (WorkflowName \"ship-order\") (WorkflowId \"ord-7\") shipWorkflow - result <- 'awaitChild' h -- SUSPEND until the child completes - _ <- 'Keiro.Workflow.step' (StepName \"notify\") (pure (\"shipped: \" <> result)) - pure result -@ - -== How it works (contract recap for downstream plans) - -* __'spawnChild' is a journaled step.__ It records a @StepRecorded - \"child:\\"@ 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, throws 'WorkflowChildFailed' from the durable child - row if it failed, and otherwise re-asserts nothing new (the spawn already - registered the link). On the hit path - it decodes a tagged parent-journal envelope: @{"ok": result}@ returns the - child result, @{"cancelled": true}@ throws 'WorkflowChildCancelled', - @{"failed": reason}@ throws 'WorkflowChildFailed', and legacy raw values are - still decoded as pre-envelope successful results. -* __'runChildWorkflow'__ is what the resume worker selects (instead of bare - 'Keiro.Workflow.runWorkflowWith') for any workflow that is some parent's child: - on 'Completed' it runs 'childCompletionHook', which flips the child row to - @completed@ and appends @{"ok": result}@ to the parent's - @child:\:result@ step. If it finds a historically - @cancelled@-but-unmarked row, it ensures the child cancellation marker and - parent sentinel before returning 'Cancelled'. -* __'cancelChild'__ flips the child row to @cancelled@ and, in the same - transaction, writes a 'Keiro.Workflow.WorkflowCancelled' marker to the - /child/ journal plus a @{"cancelled": true}@ sentinel as the parent's - await-step result. Retrying after a historical row-only cancel repairs both - markers even though the return value remains 'False' ("this call did not - transition the row"). -* @'Keiro.Workflow.Child.Schema.countActiveChildren'@ backs a potential - @keiro.workflow.children.active@ gauge for EP-44. --} -module Keiro.Workflow.Child ( - -- * Child handles and reserved step names +-- | Child workflows: spawn, wait on, and cancel a workflow from inside another. +-- +-- == What this gives you +-- +-- Fan-out\/fan-in composition of durable workflows. A /parent/ workflow spawns a +-- /child/ (a second workflow with its own journal stream), waits for the child's +-- result, and may cancel a child it no longer needs — with the whole relationship +-- surviving a crash, because the spawn is recorded in the parent's journal and the +-- link is stored in @keiro_workflow_children@. +-- +-- @ +-- parent :: ('Workflow' ':>' es, 'Store' ':>' es, 'IOE' ':>' es) => Eff es Text +-- parent = do +-- h <- 'spawnChild' (WorkflowName \"ship-order\") (WorkflowId \"ord-7\") shipWorkflow +-- result <- 'awaitChild' h -- SUSPEND until the child completes +-- _ <- 'Keiro.Workflow.step' (StepName \"notify\") (pure (\"shipped: \" <> result)) +-- pure result +-- @ +-- +-- == How it works (contract recap for downstream plans) +-- +-- * __'spawnChild' is a journaled step.__ It records a @StepRecorded +-- \"child:\\"@ 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, throws 'WorkflowChildFailed' from the durable child +-- row if it failed, and otherwise re-asserts nothing new (the spawn already +-- registered the link). On the hit path +-- it decodes a tagged parent-journal envelope: @{"ok": result}@ returns the +-- child result, @{"cancelled": true}@ throws 'WorkflowChildCancelled', +-- @{"failed": reason}@ throws 'WorkflowChildFailed', and legacy raw values are +-- still decoded as pre-envelope successful results. +-- * __'runChildWorkflow'__ is what the resume worker selects (instead of bare +-- 'Keiro.Workflow.runWorkflowWith') for any workflow that is some parent's child: +-- on 'Completed' it runs 'childCompletionHook', which flips the child row to +-- @completed@ and appends @{"ok": result}@ to the parent's +-- @child:\:result@ step. If it finds a historically +-- @cancelled@-but-unmarked row, it ensures the child cancellation marker and +-- parent sentinel before returning 'Cancelled'. +-- * __'cancelChild'__ flips the child row to @cancelled@ and, in the same +-- transaction, writes a 'Keiro.Workflow.WorkflowCancelled' marker to the +-- /child/ journal plus a @{"cancelled": true}@ sentinel as the parent's +-- await-step result. Retrying after a historical row-only cancel repairs both +-- markers even though the return value remains 'False' ("this call did not +-- transition the row"). +-- * @'Keiro.Workflow.Child.Schema.countActiveChildren'@ backs a potential +-- @keiro.workflow.children.active@ gauge for EP-44. +module Keiro.Workflow.Child + ( -- * Child handles and reserved step names ChildHandle (..), childSpawnStepName, childResultStepName, @@ -77,7 +76,7 @@ -- * Errors WorkflowChildCancelled (..), WorkflowChildFailed (..), -) + ) where import Control.Exception (Exception) @@ -88,8 +87,8 @@ import Effectful.Error.Static (Error) import Effectful.Exception (throwIO) import Keiro.Prelude -import Keiro.Workflow ( - JournalAppendOutcome (..), +import Keiro.Workflow + ( JournalAppendOutcome (..), StepName (..), Workflow, WorkflowError (..), @@ -106,15 +105,15 @@ prepareJournalAppend, runWorkflowWith, step, - ) -import Keiro.Workflow.Child.Schema ( - ChildRow, + ) +import Keiro.Workflow.Child.Schema + ( ChildRow, ChildStatus (..), lookupChild, markChildCancelledTx, markChildResultTx, registerChildTx, - ) + ) import Keiro.Workflow.Instance (WorkflowStatus (..), lookupInstance, upsertInstanceTx) import Kiroku.Store.Effect (Store) import Kiroku.Store.Error (StoreError) @@ -125,27 +124,24 @@ -- Handles and reserved step names -- --------------------------------------------------------------------------- -{- | An in-memory handle to a spawned child, returned by 'spawnChild' and taken -by 'awaitChild' \/ 'cancelChild'. The phantom type parameter @a@ records the -child's result type so 'awaitChild' decodes without an extra annotation; the -handle itself carries only the child's name and id (the child journal is -@wf:\-\@). --} +-- | 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) + { 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'). --} +-- | 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@. --} +-- | 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" @@ -153,23 +149,21 @@ -- Errors -- --------------------------------------------------------------------------- -{- | Thrown out of 'awaitChild' when the awaited child was 'cancelChild'led. A -cancelled child never produces a result, so suspending forever would be wrong -and fabricating a result would be wrong; the parent author can @catch@ this to -run compensation. If uncaught, the resume worker records the parent attempt, -backs it off, and eventually marks the parent failed at its configured ceiling. -Mirrors EP-40's 'Keiro.Workflow.Awakeable.WorkflowAwakeableCancelled'. --} +-- | Thrown out of 'awaitChild' when the awaited child was 'cancelChild'led. A +-- cancelled child never produces a result, so suspending forever would be wrong +-- and fabricating a result would be wrong; the parent author can @catch@ this to +-- run compensation. If uncaught, the resume worker records the parent attempt, +-- backs it off, and eventually marks the parent failed at its configured ceiling. +-- Mirrors EP-40's 'Keiro.Workflow.Awakeable.WorkflowAwakeableCancelled'. data WorkflowChildCancelled = WorkflowChildCancelled WorkflowName WorkflowId - deriving stock (Eq, Show) + deriving stock (Eq, Show) instance Exception WorkflowChildCancelled -{- | Thrown out of 'awaitChild' when the child was terminally failed by the -resume worker. Carries the child's identity plus the persisted failure reason. --} +-- | Thrown out of 'awaitChild' when the child was terminally failed by the +-- resume worker. Carries the child's identity plus the persisted failure reason. data WorkflowChildFailed = WorkflowChildFailed WorkflowName WorkflowId Text - deriving stock (Eq, Show) + deriving stock (Eq, Show) instance Exception WorkflowChildFailed @@ -177,272 +171,266 @@ -- Authoring surface -- --------------------------------------------------------------------------- -{- | Spawn a child workflow. Records a @StepRecorded \"child:\\"@ in -the /parent/ journal (so a replay short-circuits and never re-spawns) and -inserts an idempotent @running@ link row, then returns a 'ChildHandle'. The -child is driven to completion by the resume worker from the registry, so -@childNm@ __must be registered there__; @childDef@ is accepted for authoring -ergonomics but is not run here. - -A child id names one execution globally. Spawning an id whose child row already -completed attaches to that execution: 'awaitChild' re-delivers the stored -result onto the parent's current generation. To run a fresh child after -'Keiro.Workflow.continueAsNew', derive a fresh child id from the carried seed. --} +-- | Spawn a child workflow. Records a @StepRecorded \"child:\\"@ in +-- the /parent/ journal (so a replay short-circuits and never re-spawns) and +-- inserts an idempotent @running@ link row, then returns a 'ChildHandle'. The +-- child is driven to completion by the resume worker from the registry, so +-- @childNm@ __must be registered there__; @childDef@ is accepted for authoring +-- ergonomics but is not run here. +-- +-- A child id names one execution globally. Spawning an id whose child row already +-- completed attaches to that execution: 'awaitChild' re-delivers the stored +-- result onto the parent's current generation. To run a fresh child after +-- 'Keiro.Workflow.continueAsNew', derive a fresh child id from the carried seed. spawnChild :: - (Workflow :> es, Store :> es) => - -- | The child's name (must be in the resume worker's registry). - WorkflowName -> - -- | The child's id (names the child journal). - WorkflowId -> - -- | The child workflow definition (for authoring; the registry actually runs it). - Eff (Workflow : es) a -> - Eff es (ChildHandle a) + (Workflow :> es, Store :> es) => + -- | The child's name (must be in the resume worker's registry). + WorkflowName -> + -- | The child's id (names the child journal). + WorkflowId -> + -- | The child workflow definition (for authoring; the registry actually runs it). + Eff (Workflow : es) a -> + Eff es (ChildHandle a) spawnChild childNm childWid _childDef = do - (parentNm, parentWid) <- currentWorkflow - let spawnStep = StepName (childSpawnStepName childWid) - resultStep = childResultStepName childWid - -- Journaled as a step in the PARENT journal: a parent replay short-circuits - -- this body, and the ON CONFLICT DO NOTHING register collapses on re-run. - _ <- - step spawnStep $ do - runTransaction $ - registerChildTx - (unWorkflowId childWid) - (unWorkflowName childNm) - (unWorkflowId parentWid) - (unWorkflowName parentNm) - resultStep - *> upsertInstanceTx - (unWorkflowId childWid) - (unWorkflowName childNm) - 0 - WfRunning - Nothing - pure () - pure (ChildHandle childNm childWid) - -{- | Suspend the parent until the child completes, then return the child's -result. This is EP-38's 'awaitStep' on the @child:\:result@ step: -'childCompletionHook' journals that step into the parent when the child -finishes, so the next parent run replays past the wait and decodes the result. + (parentNm, parentWid) <- currentWorkflow + let spawnStep = StepName (childSpawnStepName childWid) + resultStep = childResultStepName childWid + -- Journaled as a step in the PARENT journal: a parent replay short-circuits + -- this body, and the ON CONFLICT DO NOTHING register collapses on re-run. + _ <- + step spawnStep $ do + runTransaction $ + registerChildTx + (unWorkflowId childWid) + (unWorkflowName childNm) + (unWorkflowId parentWid) + (unWorkflowName parentNm) + resultStep + *> upsertInstanceTx + (unWorkflowId childWid) + (unWorkflowName childNm) + 0 + WfRunning + Nothing + pure () + pure (ChildHandle childNm childWid) -If the child was cancelled or failed, throws 'WorkflowChildCancelled' or -'WorkflowChildFailed'. Parent-journal values are tagged envelopes -(@{"ok": ...}@, @{"cancelled": true}@, @{"failed": reason}@) with a legacy raw -success fallback; a decode mismatch throws 'WorkflowStepDecodeError'. --} +-- | Suspend the parent until the child completes, then return the child's +-- result. This is EP-38's 'awaitStep' on the @child:\:result@ step: +-- 'childCompletionHook' journals that step into the parent when the child +-- finishes, so the next parent run replays past the wait and decodes the result. +-- +-- If the child was cancelled or failed, throws 'WorkflowChildCancelled' or +-- 'WorkflowChildFailed'. Parent-journal values are tagged envelopes +-- (@{"ok": ...}@, @{"cancelled": true}@, @{"failed": reason}@) with a legacy raw +-- success fallback; a decode mismatch throws 'WorkflowStepDecodeError'. awaitChild :: - (Workflow :> es, Store :> es, IOE :> es, FromJSON a) => - ChildHandle a -> - Eff es a + (Workflow :> es, Store :> es, IOE :> es, FromJSON a) => + ChildHandle a -> + Eff es a awaitChild (ChildHandle childNm childWid) = do - let resultStep = StepName (childResultStepName childWid) - arm = do - mrow <- lookupChild (unWorkflowId childWid) (unWorkflowName childNm) - case mrow of - Just row - | (row ^. #status) == ChildCancelled -> - throwIO (WorkflowChildCancelled childNm childWid) - | (row ^. #status) == ChildFailed -> do - mInstance <- lookupInstance childNm childWid - let reason = - case row ^. #failureReason of - Just recorded -> recorded - Nothing -> - fromMaybe - "child workflow failed (reason not recorded)" - (mInstance >>= (^. #lastError)) - throwIO (WorkflowChildFailed childNm childWid reason) - | (row ^. #status) == ChildCompleted - , Just resultValue <- row ^. #result -> - appendJournalEntry - (WorkflowName (row ^. #parentName)) - (WorkflowId (row ^. #parentId)) - StepRecorded - { stepName = row ^. #awaitStep - , result = childOkEnvelope resultValue - , recordedAt = fromMaybe (row ^. #updatedAt) (row ^. #completedAt) - } - -- The spawn already registered the link; nothing more to (re-)arm. - _ -> pure () - raw <- awaitStep resultStep arm - decodeChildResult childNm childWid (unStepName resultStep) raw + let resultStep = StepName (childResultStepName childWid) + arm = do + mrow <- lookupChild (unWorkflowId childWid) (unWorkflowName childNm) + case mrow of + Just row + | (row ^. #status) == ChildCancelled -> + throwIO (WorkflowChildCancelled childNm childWid) + | (row ^. #status) == ChildFailed -> do + mInstance <- lookupInstance childNm childWid + let reason = + case row ^. #failureReason of + Just recorded -> recorded + Nothing -> + fromMaybe + "child workflow failed (reason not recorded)" + (mInstance >>= (^. #lastError)) + throwIO (WorkflowChildFailed childNm childWid reason) + | (row ^. #status) == ChildCompleted, + Just resultValue <- row ^. #result -> + appendJournalEntry + (WorkflowName (row ^. #parentName)) + (WorkflowId (row ^. #parentId)) + StepRecorded + { stepName = row ^. #awaitStep, + result = childOkEnvelope resultValue, + recordedAt = fromMaybe (row ^. #updatedAt) (row ^. #completedAt) + } + -- The spawn already registered the link; nothing more to (re-)arm. + _ -> pure () + raw <- awaitStep resultStep arm + decodeChildResult childNm childWid (unStepName resultStep) raw -- --------------------------------------------------------------------------- -- External control -- --------------------------------------------------------------------------- -{- | Cancel a child. For a @running@ child, flips its -@keiro_workflow_children@ row to @cancelled@ and, in the same transaction, -writes both the child's 'WorkflowCancelled' marker and the parent's -@{"cancelled": true}@ await-step sentinel. Returns 'True' only when this call -performed the row transition. For an already-@cancelled@ row, returns 'False' -but still ensures both markers, repairing historical crashes that committed the -row flip before either journal append. Already completed/failed/unknown -children return 'False' and no marker is fabricated. --} +-- | Cancel a child. For a @running@ child, flips its +-- @keiro_workflow_children@ row to @cancelled@ and, in the same transaction, +-- writes both the child's 'WorkflowCancelled' marker and the parent's +-- @{"cancelled": true}@ await-step sentinel. Returns 'True' only when this call +-- performed the row transition. For an already-@cancelled@ row, returns 'False' +-- but still ensures both markers, repairing historical crashes that committed the +-- row flip before either journal append. Already completed/failed/unknown +-- children return 'False' and no marker is fabricated. cancelChild :: - (IOE :> es, Store :> es) => - ChildHandle a -> - Eff es Bool + (IOE :> es, Store :> es) => + ChildHandle a -> + Eff es Bool cancelChild (ChildHandle childNm childWid) = do - mrow <- lookupChild (unWorkflowId childWid) (unWorkflowName childNm) - case mrow of - Nothing -> pure False - Just row -> do - (transitioned, childOutcome, parentOutcome) <- ensureChildCancelled row - throwOnAppendConflict childOutcome - throwOnAppendConflict parentOutcome - pure transitioned + mrow <- lookupChild (unWorkflowId childWid) (unWorkflowName childNm) + case mrow of + Nothing -> pure False + Just row -> do + (transitioned, childOutcome, parentOutcome) <- ensureChildCancelled row + throwOnAppendConflict childOutcome + throwOnAppendConflict parentOutcome + pure transitioned -- --------------------------------------------------------------------------- -- Completion propagation -- --------------------------------------------------------------------------- -{- | Drive a child workflow to completion, propagating its result to the parent. -This is 'runWorkflowWith' followed by 'childCompletionHook' on 'Completed': the -resume worker selects this (instead of bare 'runWorkflowWith') for any workflow -that is some parent's child, so a finished child wakes its waiting parent. A -'Suspended' child propagates nothing. A child row already marked 'ChildCancelled' -is repaired by ensuring the child cancellation marker and parent sentinel, then -returns 'Cancelled'; a 'ChildFailed' row returns 'Failed'. --} +-- | Drive a child workflow to completion, propagating its result to the parent. +-- This is 'runWorkflowWith' followed by 'childCompletionHook' on 'Completed': the +-- resume worker selects this (instead of bare 'runWorkflowWith') for any workflow +-- that is some parent's child, so a finished child wakes its waiting parent. A +-- 'Suspended' child propagates nothing. A child row already marked 'ChildCancelled' +-- is repaired by ensuring the child cancellation marker and parent sentinel, then +-- returns 'Cancelled'; a 'ChildFailed' row returns 'Failed'. runChildWorkflow :: - (IOE :> es, Store :> es, Error StoreError :> es, ToJSON a) => - WorkflowRunOptions -> - WorkflowName -> - WorkflowId -> - Eff (Workflow : es) a -> - Eff es (WorkflowOutcome a) + (IOE :> es, Store :> es, Error StoreError :> es, ToJSON a) => + WorkflowRunOptions -> + WorkflowName -> + WorkflowId -> + Eff (Workflow : es) a -> + Eff es (WorkflowOutcome a) runChildWorkflow opts childNm childWid action = do - mrow <- lookupChild (unWorkflowId childWid) (unWorkflowName childNm) - case fmap (^. #status) mrow of - Just ChildCancelled -> do - for_ mrow $ \row -> do - (_, childOutcome, parentOutcome) <- ensureChildCancelled row - throwOnAppendConflict childOutcome - throwOnAppendConflict parentOutcome - pure Cancelled - Just ChildFailed -> pure Failed - _ -> do - outcome <- runWorkflowWith opts childNm childWid action - case outcome of - Completed result -> do - childCompletionHook childNm childWid (toJSON result) - pure (Completed result) - other -> pure other + mrow <- lookupChild (unWorkflowId childWid) (unWorkflowName childNm) + case fmap (^. #status) mrow of + Just ChildCancelled -> do + for_ mrow $ \row -> do + (_, childOutcome, parentOutcome) <- ensureChildCancelled row + throwOnAppendConflict childOutcome + throwOnAppendConflict parentOutcome + pure Cancelled + Just ChildFailed -> pure Failed + _ -> do + outcome <- runWorkflowWith opts childNm childWid action + case outcome of + Completed result -> do + childCompletionHook childNm childWid (toJSON result) + pure (Completed result) + other -> pure other -{- | Propagate a finished child's result to its parent: flip the child row to -@completed@ (storing the raw result in the child row) and append an -@{"ok": result}@ @child:\:result@ 'StepRecorded' to the /parent/ -journal — exactly the wake source the parent's 'awaitChild' resolves on. The -running-row transition and parent append happen in one transaction. An -already-@completed@ row re-appends from the stored result, repairing historical -wedges; cancelled/failed children do not fabricate a success. Normally invoked -via 'runChildWorkflow'. --} +-- | Propagate a finished child's result to its parent: flip the child row to +-- @completed@ (storing the raw result in the child row) and append an +-- @{"ok": result}@ @child:\:result@ 'StepRecorded' to the /parent/ +-- journal — exactly the wake source the parent's 'awaitChild' resolves on. The +-- running-row transition and parent append happen in one transaction. An +-- already-@completed@ row re-appends from the stored result, repairing historical +-- wedges; cancelled/failed children do not fabricate a success. Normally invoked +-- via 'runChildWorkflow'. childCompletionHook :: - (IOE :> es, Store :> es) => - WorkflowName -> - WorkflowId -> - Aeson.Value -> - Eff es () + (IOE :> es, Store :> es) => + WorkflowName -> + WorkflowId -> + Aeson.Value -> + Eff es () childCompletionHook childNm childWid resultValue = do - mrow <- lookupChild (unWorkflowId childWid) (unWorkflowName childNm) - for_ mrow $ \row -> case row ^. #status of - Running -> do - now <- liftIO getCurrentTime - let parentName = WorkflowName (row ^. #parentName) - parentId = WorkflowId (row ^. #parentId) - gen <- currentGeneration parentName parentId - appendTx <- - prepareJournalAppend - parentName - parentId - gen - StepRecorded - { stepName = row ^. #awaitStep - , result = childOkEnvelope resultValue - , recordedAt = now - } - appendOutcome <- - runTransaction $ do - transitioned <- markChildResultTx (unWorkflowId childWid) (unWorkflowName childNm) resultValue now - if transitioned - then do - appendOutcome <- appendTx - condemnOnAppendConflict appendOutcome - pure appendOutcome - else pure (JournalAlreadyPresent resultValue) - throwOnAppendConflict appendOutcome - ChildCompleted -> - for_ (row ^. #result) $ \stored -> - appendJournalEntry - (WorkflowName (row ^. #parentName)) - (WorkflowId (row ^. #parentId)) - StepRecorded - { stepName = row ^. #awaitStep - , result = childOkEnvelope stored - , recordedAt = fromMaybe (row ^. #updatedAt) (row ^. #completedAt) - } - ChildCancelled -> pure () - ChildFailed -> pure () + mrow <- lookupChild (unWorkflowId childWid) (unWorkflowName childNm) + for_ mrow $ \row -> case row ^. #status of + Running -> do + now <- liftIO getCurrentTime + let parentName = WorkflowName (row ^. #parentName) + parentId = WorkflowId (row ^. #parentId) + gen <- currentGeneration parentName parentId + appendTx <- + prepareJournalAppend + parentName + parentId + gen + StepRecorded + { stepName = row ^. #awaitStep, + result = childOkEnvelope resultValue, + recordedAt = now + } + appendOutcome <- + runTransaction $ do + transitioned <- markChildResultTx (unWorkflowId childWid) (unWorkflowName childNm) resultValue now + if transitioned + then do + appendOutcome <- appendTx + condemnOnAppendConflict appendOutcome + pure appendOutcome + else pure (JournalAlreadyPresent resultValue) + throwOnAppendConflict appendOutcome + ChildCompleted -> + for_ (row ^. #result) $ \stored -> + appendJournalEntry + (WorkflowName (row ^. #parentName)) + (WorkflowId (row ^. #parentId)) + StepRecorded + { stepName = row ^. #awaitStep, + result = childOkEnvelope stored, + recordedAt = fromMaybe (row ^. #updatedAt) (row ^. #completedAt) + } + ChildCancelled -> pure () + ChildFailed -> pure () condemnOnAppendConflict :: JournalAppendOutcome -> Tx.Transaction () condemnOnAppendConflict = \case - JournalAppendConflict{} -> Tx.condemn - _ -> pure () + JournalAppendConflict {} -> Tx.condemn + _ -> pure () throwOnAppendConflict :: JournalAppendOutcome -> Eff es () throwOnAppendConflict = \case - JournalAppendConflict err -> throwIO (WorkflowJournalAppendError (Text.pack (show err))) - _ -> pure () + JournalAppendConflict err -> throwIO (WorkflowJournalAppendError (Text.pack (show err))) + _ -> pure () ensureChildCancelled :: - (IOE :> es, Store :> es) => - ChildRow -> - Eff es (Bool, JournalAppendOutcome, JournalAppendOutcome) + (IOE :> es, Store :> es) => + ChildRow -> + Eff es (Bool, JournalAppendOutcome, JournalAppendOutcome) ensureChildCancelled row = do - now <- liftIO getCurrentTime - let childNm = WorkflowName (row ^. #childName) - childWid = WorkflowId (row ^. #childId) - parentNm = WorkflowName (row ^. #parentName) - parentWid = WorkflowId (row ^. #parentId) - childGen <- currentGeneration childNm childWid - parentGen <- currentGeneration parentNm parentWid - childAppendTx <- prepareJournalAppend childNm childWid childGen WorkflowCancelled{recordedAt = now} - parentAppendTx <- - prepareJournalAppend - parentNm - parentWid - parentGen - StepRecorded - { stepName = row ^. #awaitStep - , result = cancelledSentinel - , recordedAt = now - } - runTransaction $ do - transitioned <- - if row ^. #status == Running - then markChildCancelledTx (row ^. #childId) (row ^. #childName) - else pure False - if transitioned || row ^. #status == ChildCancelled - then do - childOutcome <- childAppendTx - parentOutcome <- parentAppendTx - condemnOnAppendConflict childOutcome - condemnOnAppendConflict parentOutcome - pure (transitioned, childOutcome, parentOutcome) - else pure (False, JournalAlreadyPresent Aeson.Null, JournalAlreadyPresent Aeson.Null) + now <- liftIO getCurrentTime + let childNm = WorkflowName (row ^. #childName) + childWid = WorkflowId (row ^. #childId) + parentNm = WorkflowName (row ^. #parentName) + parentWid = WorkflowId (row ^. #parentId) + childGen <- currentGeneration childNm childWid + parentGen <- currentGeneration parentNm parentWid + childAppendTx <- prepareJournalAppend childNm childWid childGen WorkflowCancelled {recordedAt = now} + parentAppendTx <- + prepareJournalAppend + parentNm + parentWid + parentGen + StepRecorded + { stepName = row ^. #awaitStep, + result = cancelledSentinel, + recordedAt = now + } + runTransaction $ do + transitioned <- + if row ^. #status == Running + then markChildCancelledTx (row ^. #childId) (row ^. #childName) + else pure False + if transitioned || row ^. #status == ChildCancelled + then do + childOutcome <- childAppendTx + parentOutcome <- parentAppendTx + condemnOnAppendConflict childOutcome + condemnOnAppendConflict parentOutcome + pure (transitioned, childOutcome, parentOutcome) + else pure (False, JournalAlreadyPresent Aeson.Null, JournalAlreadyPresent Aeson.Null) -- --------------------------------------------------------------------------- -- The cancellation sentinel -- --------------------------------------------------------------------------- -{- | The @{"cancelled": true}@ value 'cancelChild' writes as a cancelled child's -await-step result so 'awaitChild' can detect it and throw. --} +-- | The @{"cancelled": true}@ value 'cancelChild' writes as a cancelled child's +-- await-step result so 'awaitChild' can detect it and throw. cancelledSentinel :: Aeson.Value cancelledSentinel = Aeson.object ["cancelled" Aeson..= True] @@ -450,24 +438,24 @@ childOkEnvelope value = Aeson.object ["ok" Aeson..= value] decodeChildResult :: - (FromJSON a) => - WorkflowName -> - WorkflowId -> - Text -> - Aeson.Value -> - Eff es a + (FromJSON a) => + WorkflowName -> + WorkflowId -> + Text -> + Aeson.Value -> + Eff es a decodeChildResult childNm childWid key raw = - case raw of - Aeson.Object obj - | Just okValue <- KeyMap.lookup "ok" obj -> - decodeOrThrow okValue - | Just (Aeson.Bool True) <- KeyMap.lookup "cancelled" obj -> - throwIO (WorkflowChildCancelled childNm childWid) - | Just (Aeson.String reason) <- KeyMap.lookup "failed" obj -> - throwIO (WorkflowChildFailed childNm childWid reason) - _ -> decodeOrThrow raw + case raw of + Aeson.Object obj + | Just okValue <- KeyMap.lookup "ok" obj -> + decodeOrThrow okValue + | Just (Aeson.Bool True) <- KeyMap.lookup "cancelled" obj -> + throwIO (WorkflowChildCancelled childNm childWid) + | Just (Aeson.String reason) <- KeyMap.lookup "failed" obj -> + throwIO (WorkflowChildFailed childNm childWid reason) + _ -> decodeOrThrow raw where decodeOrThrow value = - case Aeson.fromJSON value of - Aeson.Success a -> pure a - Aeson.Error e -> throwIO (WorkflowStepDecodeError key (Text.pack e)) + case Aeson.fromJSON value of + Aeson.Success a -> pure a + Aeson.Error e -> throwIO (WorkflowStepDecodeError key (Text.pack e)) diff --git a/src/Keiro/Workflow/Child/Schema.hs b/src/Keiro/Workflow/Child/Schema.hs --- a/src/Keiro/Workflow/Child/Schema.hs +++ b/src/Keiro/Workflow/Child/Schema.hs @@ -1,30 +1,29 @@ -{- | The @keiro_workflow_children@ table: durable parent↔child workflow links. - -Mirrors the @Keiro.Timer@ \/ @Keiro.Timer.Schema@ and -@Keiro.Workflow.Awakeable.Schema@ split: this module owns the row type, the -'ChildStatus' lifecycle, and the hasql statements; "Keiro.Workflow.Child" owns -the effectful spawn\/await\/cancel surface. - -* 'registerChildTx' inserts a @running@ row idempotently (the - @ON CONFLICT (child_id, child_name) DO NOTHING@ EP-38's @awaitStep@ arming - contract requires — a resumed parent re-runs the arm on every resume). -* 'lookupChild' \/ 'lookupChildrenOfParent' read rows back (operator - inspection and the @awaitChild@ arm's cancellation check). -* 'markChildResultTx' transitions a @running@ row to @completed@ (storing the - child's result), 'markChildCancelledTx' transitions it to @cancelled@, and - 'markChildFailedTx' transitions it to @failed@ while preserving the reason; - all guard on @status = 'running'@ so a double-resolve is a no-op. -* 'findRunningChildIds' is the resume worker's discovery seed for a zero-step - child (one that has been spawned but not yet driven, so has no - @keiro_workflow_steps@ rows for 'findUnfinishedWorkflowIds' to find). -* 'countActiveChildren' counts outstanding children — the seam EP-44 may read - for a @keiro.workflow.children.active@ gauge. - -Callers normally use the surface from "Keiro.Workflow.Child" rather than this -module directly. --} -module Keiro.Workflow.Child.Schema ( - -- * Rows and status +-- | The @keiro_workflow_children@ table: durable parent↔child workflow links. +-- +-- Mirrors the @Keiro.Timer@ \/ @Keiro.Timer.Schema@ and +-- @Keiro.Workflow.Awakeable.Schema@ split: this module owns the row type, the +-- 'ChildStatus' lifecycle, and the hasql statements; "Keiro.Workflow.Child" owns +-- the effectful spawn\/await\/cancel surface. +-- +-- * 'registerChildTx' inserts a @running@ row idempotently (the +-- @ON CONFLICT (child_id, child_name) DO NOTHING@ EP-38's @awaitStep@ arming +-- contract requires — a resumed parent re-runs the arm on every resume). +-- * 'lookupChild' \/ 'lookupChildrenOfParent' read rows back (operator +-- inspection and the @awaitChild@ arm's cancellation check). +-- * 'markChildResultTx' transitions a @running@ row to @completed@ (storing the +-- child's result), 'markChildCancelledTx' transitions it to @cancelled@, and +-- 'markChildFailedTx' transitions it to @failed@ while preserving the reason; +-- all guard on @status = 'running'@ so a double-resolve is a no-op. +-- * 'findRunningChildIds' is the resume worker's discovery seed for a zero-step +-- child (one that has been spawned but not yet driven, so has no +-- @keiro_workflow_steps@ rows for 'findUnfinishedWorkflowIds' to find). +-- * 'countActiveChildren' counts outstanding children — the seam EP-44 may read +-- for a @keiro.workflow.children.active@ gauge. +-- +-- Callers normally use the surface from "Keiro.Workflow.Child" rather than this +-- module directly. +module Keiro.Workflow.Child.Schema + ( -- * Rows and status ChildStatus (..), ChildRow (..), statusToText, @@ -43,7 +42,7 @@ childStatus, countActiveChildren, findRunningChildIds, -) + ) where import Contravariant.Extras (contrazip2, contrazip3, contrazip4, contrazip5) @@ -56,299 +55,290 @@ import Kiroku.Store.Transaction (runTransaction) import "hasql-transaction" Hasql.Transaction qualified as Tx -{- | A child workflow's lifecycle, as seen from its parent. - -* 'Running' — spawned and not yet finished; the resume worker drives it. -* 'ChildCompleted' — the child reached its own 'Keiro.Workflow.WorkflowCompleted' - and its result was propagated to the parent journal; terminal. -* 'ChildCancelled' — the parent 'Keiro.Workflow.Child.cancelChild'led it; - terminal; also the decode fallback for an unrecognized stored value (the same - defensive choice "Keiro.Timer.Schema" makes). - -The constructors are prefixed @Child@ to avoid clashing with -'Keiro.Workflow.WorkflowOutcome''s @Completed@ and the awakeable\/timer -@Cancelled@ constructors. --} +-- | A child workflow's lifecycle, as seen from its parent. +-- +-- * 'Running' — spawned and not yet finished; the resume worker drives it. +-- * 'ChildCompleted' — the child reached its own 'Keiro.Workflow.WorkflowCompleted' +-- and its result was propagated to the parent journal; terminal. +-- * 'ChildCancelled' — the parent 'Keiro.Workflow.Child.cancelChild'led it; +-- terminal; also the decode fallback for an unrecognized stored value (the same +-- defensive choice "Keiro.Timer.Schema" makes). +-- +-- The constructors are prefixed @Child@ to avoid clashing with +-- 'Keiro.Workflow.WorkflowOutcome''s @Completed@ and the awakeable\/timer +-- @Cancelled@ constructors. data ChildStatus - = Running - | ChildCompleted - | ChildCancelled - | ChildFailed - deriving stock (Generic, Eq, Show) + = Running + | ChildCompleted + | ChildCancelled + | ChildFailed + deriving stock (Generic, Eq, Show) -{- | A child link row as stored: the child's (id, name), the parent's (id, -name), the parent-journal step the parent awaits ('awaitStep' = -@child:\:result@), the live 'status', the child's 'result' (set only -once 'ChildCompleted'), the terminal 'failureReason' (set only once -'ChildFailed'), and the timestamps. --} +-- | A child link row as stored: the child's (id, name), the parent's (id, +-- name), the parent-journal step the parent awaits ('awaitStep' = +-- @child:\:result@), the live 'status', the child's 'result' (set only +-- once 'ChildCompleted'), the terminal 'failureReason' (set only once +-- 'ChildFailed'), and the timestamps. data ChildRow = ChildRow - { childId :: !Text - , childName :: !Text - , parentId :: !Text - , parentName :: !Text - , awaitStep :: !Text - , status :: !ChildStatus - , result :: !(Maybe Value) - , failureReason :: !(Maybe Text) - , createdAt :: !UTCTime - , updatedAt :: !UTCTime - , completedAt :: !(Maybe UTCTime) - } - deriving stock (Generic, Eq, Show) + { childId :: !Text, + childName :: !Text, + parentId :: !Text, + parentName :: !Text, + awaitStep :: !Text, + status :: !ChildStatus, + result :: !(Maybe Value), + failureReason :: !(Maybe Text), + createdAt :: !UTCTime, + updatedAt :: !UTCTime, + completedAt :: !(Maybe UTCTime) + } + deriving stock (Generic, Eq, Show) -{- | Insert a @running@ child link row inside the caller's transaction, given -the child's @(id, name)@, the parent's @(id, name)@, and the parent-journal -step the parent awaits (@await_step@). Idempotent by -@ON CONFLICT (child_id, child_name) DO NOTHING@ — exactly what EP-38's "arm -must be idempotent" contract needs, since the spawn step and every resume's arm -re-run it. @status@, @result@, and the timestamps take their table defaults, so -no clock read is needed at the spawn site (mirrors -'Keiro.Workflow.Awakeable.Schema.registerAwakeableTx'). --} +-- | Insert a @running@ child link row inside the caller's transaction, given +-- the child's @(id, name)@, the parent's @(id, name)@, and the parent-journal +-- step the parent awaits (@await_step@). Idempotent by +-- @ON CONFLICT (child_id, child_name) DO NOTHING@ — exactly what EP-38's "arm +-- must be idempotent" contract needs, since the spawn step and every resume's arm +-- re-run it. @status@, @result@, and the timestamps take their table defaults, so +-- no clock read is needed at the spawn site (mirrors +-- 'Keiro.Workflow.Awakeable.Schema.registerAwakeableTx'). registerChildTx :: Text -> Text -> Text -> Text -> Text -> Tx.Transaction () registerChildTx cid cname pid pname awaitStep = - Tx.statement (cid, cname, pid, pname, awaitStep) registerChildStmt + Tx.statement (cid, cname, pid, pname, awaitStep) registerChildStmt -{- | Transition a @running@ child to @completed@, storing @result@ and the -completion time, inside the caller's transaction. The @status = 'running'@ -guard makes a double-complete a no-op; returns 'True' only when this call -performed the transition. --} +-- | Transition a @running@ child to @completed@, storing @result@ and the +-- completion time, inside the caller's transaction. The @status = 'running'@ +-- guard makes a double-complete a no-op; returns 'True' only when this call +-- performed the transition. markChildResultTx :: Text -> Text -> Value -> UTCTime -> Tx.Transaction Bool markChildResultTx cid cname result now = - Tx.statement (cid, cname, result, now) markChildResultStmt + Tx.statement (cid, cname, result, now) markChildResultStmt -{- | Transition a @running@ child to @cancelled@ inside the caller's -transaction. Only @running@ rows match, so an already-completed (or -already-cancelled) child is left untouched and the call returns 'False'. --} +-- | Transition a @running@ child to @cancelled@ inside the caller's +-- transaction. Only @running@ rows match, so an already-completed (or +-- already-cancelled) child is left untouched and the call returns 'False'. markChildCancelledTx :: Text -> Text -> Tx.Transaction Bool markChildCancelledTx cid cname = - Tx.statement (cid, cname) markChildCancelledStmt + Tx.statement (cid, cname) markChildCancelledStmt -{- | Transition a @running@ child to @failed@, preserving the terminal reason. -The guarded transition and the parent's failure journal append are performed -in one caller-owned transaction by the resume worker. --} +-- | Transition a @running@ child to @failed@, preserving the terminal reason. +-- The guarded transition and the parent's failure journal append are performed +-- in one caller-owned transaction by the resume worker. markChildFailedTx :: Text -> Text -> Text -> Tx.Transaction Bool markChildFailedTx cid cname reason = - Tx.statement (cid, cname, reason) markChildFailedStmt + Tx.statement (cid, cname, reason) markChildFailedStmt -{- | Revive a @failed@ child link so the resume worker can drive the child -again. Clears terminal result metadata; the parent journal's already-delivered -failure sentinel remains immutable history. --} +-- | Revive a @failed@ child link so the resume worker can drive the child +-- again. Clears terminal result metadata; the parent journal's already-delivered +-- failure sentinel remains immutable history. reviveFailedChildTx :: Text -> Text -> Tx.Transaction Bool reviveFailedChildTx cid cname = - Tx.statement (cid, cname) reviveFailedChildStmt + Tx.statement (cid, cname) reviveFailedChildStmt -- | Read a child link row by @(child_id, child_name)@. 'Nothing' if absent. lookupChild :: (Store :> es) => Text -> Text -> Eff es (Maybe ChildRow) lookupChild cid cname = - runTransaction (Tx.statement (cid, cname) lookupChildStmt) + runTransaction (Tx.statement (cid, cname) lookupChildStmt) -- | Read every child link of a parent @(parent_id, parent_name)@. lookupChildrenOfParent :: (Store :> es) => Text -> Text -> Eff es [ChildRow] lookupChildrenOfParent pid pname = - runTransaction (Tx.statement (pid, pname) lookupChildrenOfParentStmt) + runTransaction (Tx.statement (pid, pname) lookupChildrenOfParentStmt) -- | The 'ChildStatus' of a child by @(child_id, child_name)@, if it exists. childStatus :: (Store :> es) => Text -> Text -> Eff es (Maybe ChildStatus) childStatus cid cname = fmap (^. #status) <$> lookupChild cid cname -{- | Count children currently @running@. Read-only. EP-44 may back a -@keiro.workflow.children.active@ gauge with this. --} +-- | Count children currently @running@. Read-only. EP-44 may back a +-- @keiro.workflow.children.active@ gauge with this. countActiveChildren :: (Store :> es) => Eff es Int countActiveChildren = - runTransaction (Tx.statement () countActiveChildrenStmt) + runTransaction (Tx.statement () countActiveChildrenStmt) -{- | The @(child_id, child_name)@ of every @running@ child. The resume worker -unions this with 'Keiro.Workflow.findUnfinishedWorkflowIds' so a freshly -spawned child that has no @keiro_workflow_steps@ rows yet is still discovered -and driven. The tuple order matches 'findUnfinishedWorkflowIds' — @(id, name)@. --} +-- | The @(child_id, child_name)@ of every @running@ child. The resume worker +-- unions this with 'Keiro.Workflow.findUnfinishedWorkflowIds' so a freshly +-- spawned child that has no @keiro_workflow_steps@ rows yet is still discovered +-- and driven. The tuple order matches 'findUnfinishedWorkflowIds' — @(id, name)@. findRunningChildIds :: (Store :> es) => Eff es [(Text, Text)] findRunningChildIds = - runTransaction (Tx.statement () findRunningChildIdsStmt) + runTransaction (Tx.statement () findRunningChildIdsStmt) registerChildStmt :: Statement (Text, Text, Text, Text, Text) () registerChildStmt = - preparable - """ - INSERT INTO keiro.keiro_workflow_children - (child_id, child_name, parent_id, parent_name, await_step, status) - VALUES ($1, $2, $3, $4, $5, 'running') - ON CONFLICT (child_id, child_name) DO NOTHING - """ - ( contrazip5 - (E.param (E.nonNullable E.text)) - (E.param (E.nonNullable E.text)) - (E.param (E.nonNullable E.text)) - (E.param (E.nonNullable E.text)) - (E.param (E.nonNullable E.text)) - ) - D.noResult + preparable + """ + INSERT INTO keiro.keiro_workflow_children + (child_id, child_name, parent_id, parent_name, await_step, status) + VALUES ($1, $2, $3, $4, $5, 'running') + ON CONFLICT (child_id, child_name) DO NOTHING + """ + ( contrazip5 + (E.param (E.nonNullable E.text)) + (E.param (E.nonNullable E.text)) + (E.param (E.nonNullable E.text)) + (E.param (E.nonNullable E.text)) + (E.param (E.nonNullable E.text)) + ) + D.noResult markChildResultStmt :: Statement (Text, Text, Value, UTCTime) Bool markChildResultStmt = - preparable - """ - UPDATE keiro.keiro_workflow_children - SET status = 'completed', - result = $3, - completed_at = $4, - updated_at = now() - WHERE child_id = $1 - AND child_name = $2 - AND status = 'running' - """ - ( contrazip4 - (E.param (E.nonNullable E.text)) - (E.param (E.nonNullable E.text)) - (E.param (E.nonNullable E.jsonb)) - (E.param (E.nonNullable E.timestamptz)) - ) - ((> 0) <$> D.rowsAffected) + preparable + """ + UPDATE keiro.keiro_workflow_children + SET status = 'completed', + result = $3, + completed_at = $4, + updated_at = now() + WHERE child_id = $1 + AND child_name = $2 + AND status = 'running' + """ + ( contrazip4 + (E.param (E.nonNullable E.text)) + (E.param (E.nonNullable E.text)) + (E.param (E.nonNullable E.jsonb)) + (E.param (E.nonNullable E.timestamptz)) + ) + ((> 0) <$> D.rowsAffected) markChildCancelledStmt :: Statement (Text, Text) Bool markChildCancelledStmt = - preparable - """ - UPDATE keiro.keiro_workflow_children - SET status = 'cancelled', - updated_at = now() - WHERE child_id = $1 - AND child_name = $2 - AND status = 'running' - """ - ( contrazip2 - (E.param (E.nonNullable E.text)) - (E.param (E.nonNullable E.text)) - ) - ((> 0) <$> D.rowsAffected) + preparable + """ + UPDATE keiro.keiro_workflow_children + SET status = 'cancelled', + updated_at = now() + WHERE child_id = $1 + AND child_name = $2 + AND status = 'running' + """ + ( contrazip2 + (E.param (E.nonNullable E.text)) + (E.param (E.nonNullable E.text)) + ) + ((> 0) <$> D.rowsAffected) markChildFailedStmt :: Statement (Text, Text, Text) Bool markChildFailedStmt = - preparable - """ - UPDATE keiro.keiro_workflow_children - SET status = 'failed', - failure_reason = $3, - updated_at = now() - WHERE child_id = $1 - AND child_name = $2 - AND status = 'running' - """ - ( contrazip3 - (E.param (E.nonNullable E.text)) - (E.param (E.nonNullable E.text)) - (E.param (E.nonNullable E.text)) - ) - ((> 0) <$> D.rowsAffected) + preparable + """ + UPDATE keiro.keiro_workflow_children + SET status = 'failed', + failure_reason = $3, + updated_at = now() + WHERE child_id = $1 + AND child_name = $2 + AND status = 'running' + """ + ( contrazip3 + (E.param (E.nonNullable E.text)) + (E.param (E.nonNullable E.text)) + (E.param (E.nonNullable E.text)) + ) + ((> 0) <$> D.rowsAffected) reviveFailedChildStmt :: Statement (Text, Text) Bool reviveFailedChildStmt = - preparable - """ - UPDATE keiro.keiro_workflow_children - SET status = 'running', - result = NULL, - failure_reason = NULL, - completed_at = NULL, - updated_at = now() - WHERE child_id = $1 - AND child_name = $2 - AND status = 'failed' - """ - ( contrazip2 - (E.param (E.nonNullable E.text)) - (E.param (E.nonNullable E.text)) - ) - ((> 0) <$> D.rowsAffected) + preparable + """ + UPDATE keiro.keiro_workflow_children + SET status = 'running', + result = NULL, + failure_reason = NULL, + completed_at = NULL, + updated_at = now() + WHERE child_id = $1 + AND child_name = $2 + AND status = 'failed' + """ + ( contrazip2 + (E.param (E.nonNullable E.text)) + (E.param (E.nonNullable E.text)) + ) + ((> 0) <$> D.rowsAffected) lookupChildStmt :: Statement (Text, Text) (Maybe ChildRow) lookupChildStmt = - preparable - """ - SELECT child_id, child_name, parent_id, parent_name, await_step, - status, result, failure_reason, created_at, updated_at, completed_at - FROM keiro.keiro_workflow_children - WHERE child_id = $1 - AND child_name = $2 - """ - ( contrazip2 - (E.param (E.nonNullable E.text)) - (E.param (E.nonNullable E.text)) - ) - (D.rowMaybe childRowDecoder) + preparable + """ + SELECT child_id, child_name, parent_id, parent_name, await_step, + status, result, failure_reason, created_at, updated_at, completed_at + FROM keiro.keiro_workflow_children + WHERE child_id = $1 + AND child_name = $2 + """ + ( contrazip2 + (E.param (E.nonNullable E.text)) + (E.param (E.nonNullable E.text)) + ) + (D.rowMaybe childRowDecoder) lookupChildrenOfParentStmt :: Statement (Text, Text) [ChildRow] lookupChildrenOfParentStmt = - preparable - """ - SELECT child_id, child_name, parent_id, parent_name, await_step, - status, result, failure_reason, created_at, updated_at, completed_at - FROM keiro.keiro_workflow_children - WHERE parent_id = $1 - AND parent_name = $2 - ORDER BY created_at, child_id - """ - ( contrazip2 - (E.param (E.nonNullable E.text)) - (E.param (E.nonNullable E.text)) - ) - (D.rowList childRowDecoder) + preparable + """ + SELECT child_id, child_name, parent_id, parent_name, await_step, + status, result, failure_reason, created_at, updated_at, completed_at + FROM keiro.keiro_workflow_children + WHERE parent_id = $1 + AND parent_name = $2 + ORDER BY created_at, child_id + """ + ( contrazip2 + (E.param (E.nonNullable E.text)) + (E.param (E.nonNullable E.text)) + ) + (D.rowList childRowDecoder) countActiveChildrenStmt :: Statement () Int countActiveChildrenStmt = - preparable - """ - SELECT count(*) - FROM keiro.keiro_workflow_children - WHERE status = 'running' - """ - E.noParams - (D.singleRow (fromIntegral <$> D.column (D.nonNullable D.int8))) + preparable + """ + SELECT count(*) + FROM keiro.keiro_workflow_children + WHERE status = 'running' + """ + E.noParams + (D.singleRow (fromIntegral <$> D.column (D.nonNullable D.int8))) findRunningChildIdsStmt :: Statement () [(Text, Text)] findRunningChildIdsStmt = - preparable - """ - SELECT child_id, child_name - FROM keiro.keiro_workflow_children - WHERE status = 'running' - """ - E.noParams - (D.rowList ((,) <$> D.column (D.nonNullable D.text) <*> D.column (D.nonNullable D.text))) + preparable + """ + SELECT child_id, child_name + FROM keiro.keiro_workflow_children + WHERE status = 'running' + """ + E.noParams + (D.rowList ((,) <$> D.column (D.nonNullable D.text) <*> D.column (D.nonNullable D.text))) childRowDecoder :: D.Row ChildRow childRowDecoder = - ChildRow - <$> D.column (D.nonNullable D.text) - <*> D.column (D.nonNullable D.text) - <*> D.column (D.nonNullable D.text) - <*> D.column (D.nonNullable D.text) - <*> D.column (D.nonNullable D.text) - <*> (statusFromText <$> D.column (D.nonNullable D.text)) - <*> D.column (D.nullable D.jsonb) - <*> D.column (D.nullable D.text) - <*> D.column (D.nonNullable D.timestamptz) - <*> D.column (D.nonNullable D.timestamptz) - <*> D.column (D.nullable D.timestamptz) + ChildRow + <$> D.column (D.nonNullable D.text) + <*> D.column (D.nonNullable D.text) + <*> D.column (D.nonNullable D.text) + <*> D.column (D.nonNullable D.text) + <*> D.column (D.nonNullable D.text) + <*> (statusFromText <$> D.column (D.nonNullable D.text)) + <*> D.column (D.nullable D.jsonb) + <*> D.column (D.nullable D.text) + <*> D.column (D.nonNullable D.timestamptz) + <*> D.column (D.nonNullable D.timestamptz) + <*> D.column (D.nullable D.timestamptz) statusToText :: ChildStatus -> Text statusToText = \case - Running -> "running" - ChildCompleted -> "completed" - ChildCancelled -> "cancelled" - ChildFailed -> "failed" + Running -> "running" + ChildCompleted -> "completed" + ChildCancelled -> "cancelled" + ChildFailed -> "failed" statusFromText :: Text -> ChildStatus statusFromText = \case - "running" -> Running - "completed" -> ChildCompleted - "cancelled" -> ChildCancelled - "failed" -> ChildFailed - _ -> ChildCancelled + "running" -> Running + "completed" -> ChildCompleted + "cancelled" -> ChildCancelled + "failed" -> ChildFailed + _ -> ChildCancelled diff --git a/src/Keiro/Workflow/Gc.hs b/src/Keiro/Workflow/Gc.hs --- a/src/Keiro/Workflow/Gc.hs +++ b/src/Keiro/Workflow/Gc.hs @@ -1,19 +1,18 @@ -{- | Optional garbage collection for terminal workflow instances. - -The hot-path schema modules keep lifecycle writes and lookup statements. This -module owns only cleanup statements used by an operator-scheduled GC pass. -Eligibility is based on the derived @keiro_workflows@ row: terminal instances -older than the retention cutoff are deleted, except completed children whose -parent is still non-terminal and may still attach to their result. Cleanup -removes workflow-sleep timers in every lifecycle state so no scheduled timer -can later recreate a collected workflow. --} -module Keiro.Workflow.Gc ( - WorkflowGcPolicy (..), +-- | Optional garbage collection for terminal workflow instances. +-- +-- The hot-path schema modules keep lifecycle writes and lookup statements. This +-- module owns only cleanup statements used by an operator-scheduled GC pass. +-- Eligibility is based on the derived @keiro_workflows@ row: terminal instances +-- older than the retention cutoff are deleted, except completed children whose +-- parent is still non-terminal and may still attach to their result. Cleanup +-- removes workflow-sleep timers in every lifecycle state so no scheduled timer +-- can later recreate a collected workflow. +module Keiro.Workflow.Gc + ( WorkflowGcPolicy (..), WorkflowGcSummary (..), gcWorkflowsOnce, runWorkflowGcWorker, -) + ) where import Contravariant.Extras (contrazip2, contrazip3, contrazip4) @@ -36,161 +35,161 @@ import "hasql-transaction" Hasql.Transaction qualified as Tx data WorkflowGcPolicy = WorkflowGcPolicy - { retention :: !NominalDiffTime - , batchSize :: !Int - } - deriving stock (Generic, Eq, Show) + { retention :: !NominalDiffTime, + batchSize :: !Int + } + deriving stock (Generic, Eq, Show) data WorkflowGcSummary = WorkflowGcSummary - { scanned :: !Int - , deleted :: !Int - } - deriving stock (Generic, Eq, Show) + { scanned :: !Int, + deleted :: !Int + } + deriving stock (Generic, Eq, Show) gcWorkflowsOnce :: (Store :> es) => UTCTime -> WorkflowGcPolicy -> Eff es WorkflowGcSummary gcWorkflowsOnce now policy = do - let cutoff = addUTCTime (negate (policy ^. #retention)) now - limit = max 0 (policy ^. #batchSize) - eligible <- runTransaction (Tx.statement (cutoff, fromIntegral limit :: Int32) eligibleWorkflowsStmt) - deletedCount <- length <$> traverse deleteWorkflow eligible - pure WorkflowGcSummary{scanned = length eligible, deleted = deletedCount} + let cutoff = addUTCTime (negate (policy ^. #retention)) now + limit = max 0 (policy ^. #batchSize) + eligible <- runTransaction (Tx.statement (cutoff, fromIntegral limit :: Int32) eligibleWorkflowsStmt) + deletedCount <- length <$> traverse deleteWorkflow eligible + pure WorkflowGcSummary {scanned = length eligible, deleted = deletedCount} runWorkflowGcWorker :: (IOE :> es, Store :> es) => WorkflowGcPolicy -> Int -> Eff es () runWorkflowGcWorker policy pollMicros = - forever $ do - now <- liftIO getCurrentTime - void (gcWorkflowsOnce now policy) - liftIO (threadDelay pollMicros) + forever $ do + now <- liftIO getCurrentTime + void (gcWorkflowsOnce now policy) + liftIO (threadDelay pollMicros) deleteWorkflow :: (Store :> es) => (Text, Text) -> Eff es () deleteWorkflow (widText, nameText) = do - let name = WorkflowName nameText - wid = WorkflowId widText - gen <- currentGeneration name wid - for_ [0 .. gen] $ \generation -> do - let streamName = workflowGenerationStreamName name wid generation - mStreamId <- lookupStreamId streamName - for_ mStreamId $ \(StreamId sid) -> - runTransaction (Tx.statement sid deleteSnapshotStmt) - void (hardDeleteStream streamName) - runTransaction $ do - Tx.statement (widText, nameText) deleteStepsStmt - Tx.statement (nameText, widText) deleteAwakeablesStmt - Tx.statement (widText, nameText, widText, nameText) deleteChildrenStmt - -- Eligibility is already terminal, so remove every owned sleep timer: - -- a scheduled survivor could otherwise recreate this workflow later. - -- Keep this literal in sync with Keiro.Workflow.Sleep.workflowSleepKind. - Tx.statement (widText, nameText, workflowSleepKindLiteral) deleteSleepTimersStmt - Tx.statement (widText, nameText) deleteWorkflowStmt + let name = WorkflowName nameText + wid = WorkflowId widText + gen <- currentGeneration name wid + for_ [0 .. gen] $ \generation -> do + let streamName = workflowGenerationStreamName name wid generation + mStreamId <- lookupStreamId streamName + for_ mStreamId $ \(StreamId sid) -> + runTransaction (Tx.statement sid deleteSnapshotStmt) + void (hardDeleteStream streamName) + runTransaction $ do + Tx.statement (widText, nameText) deleteStepsStmt + Tx.statement (nameText, widText) deleteAwakeablesStmt + Tx.statement (widText, nameText, widText, nameText) deleteChildrenStmt + -- Eligibility is already terminal, so remove every owned sleep timer: + -- a scheduled survivor could otherwise recreate this workflow later. + -- Keep this literal in sync with Keiro.Workflow.Sleep.workflowSleepKind. + Tx.statement (widText, nameText, workflowSleepKindLiteral) deleteSleepTimersStmt + Tx.statement (widText, nameText) deleteWorkflowStmt workflowSleepKindLiteral :: Text workflowSleepKindLiteral = "keiro.workflow.sleep" eligibleWorkflowsStmt :: Statement (UTCTime, Int32) [(Text, Text)] eligibleWorkflowsStmt = - preparable - """ - SELECT w.workflow_id, w.workflow_name - FROM keiro.keiro_workflows w - WHERE w.status IN ('completed', 'cancelled', 'failed') - AND w.completed_at IS NOT NULL - AND w.completed_at <= $1 - AND NOT EXISTS ( - SELECT 1 - FROM keiro.keiro_workflow_children c - JOIN keiro.keiro_workflows p - ON p.workflow_id = c.parent_id - AND p.workflow_name = c.parent_name - WHERE c.child_id = w.workflow_id - AND c.child_name = w.workflow_name - AND p.status NOT IN ('completed', 'cancelled', 'failed') - ) - ORDER BY w.completed_at - LIMIT $2 - """ - ( contrazip2 - (E.param (E.nonNullable E.timestamptz)) - (E.param (E.nonNullable E.int4)) - ) - (D.rowList ((,) <$> D.column (D.nonNullable D.text) <*> D.column (D.nonNullable D.text))) + preparable + """ + SELECT w.workflow_id, w.workflow_name + FROM keiro.keiro_workflows w + WHERE w.status IN ('completed', 'cancelled', 'failed') + AND w.completed_at IS NOT NULL + AND w.completed_at <= $1 + AND NOT EXISTS ( + SELECT 1 + FROM keiro.keiro_workflow_children c + JOIN keiro.keiro_workflows p + ON p.workflow_id = c.parent_id + AND p.workflow_name = c.parent_name + WHERE c.child_id = w.workflow_id + AND c.child_name = w.workflow_name + AND p.status NOT IN ('completed', 'cancelled', 'failed') + ) + ORDER BY w.completed_at + LIMIT $2 + """ + ( contrazip2 + (E.param (E.nonNullable E.timestamptz)) + (E.param (E.nonNullable E.int4)) + ) + (D.rowList ((,) <$> D.column (D.nonNullable D.text) <*> D.column (D.nonNullable D.text))) deleteSnapshotStmt :: Statement Int64 () deleteSnapshotStmt = - preparable - """ - DELETE FROM keiro.keiro_snapshots - WHERE stream_id = $1 - """ - (E.param (E.nonNullable E.int8)) - D.noResult + preparable + """ + DELETE FROM keiro.keiro_snapshots + WHERE stream_id = $1 + """ + (E.param (E.nonNullable E.int8)) + D.noResult deleteStepsStmt :: Statement (Text, Text) () deleteStepsStmt = - preparable - """ - DELETE FROM keiro.keiro_workflow_steps - WHERE workflow_id = $1 AND workflow_name = $2 - """ - ( contrazip2 - (E.param (E.nonNullable E.text)) - (E.param (E.nonNullable E.text)) - ) - D.noResult + preparable + """ + DELETE FROM keiro.keiro_workflow_steps + WHERE workflow_id = $1 AND workflow_name = $2 + """ + ( contrazip2 + (E.param (E.nonNullable E.text)) + (E.param (E.nonNullable E.text)) + ) + D.noResult deleteAwakeablesStmt :: Statement (Text, Text) () deleteAwakeablesStmt = - preparable - """ - DELETE FROM keiro.keiro_awakeables - WHERE owner_workflow_name = $1 AND owner_workflow_id = $2 - """ - ( contrazip2 - (E.param (E.nonNullable E.text)) - (E.param (E.nonNullable E.text)) - ) - D.noResult + preparable + """ + DELETE FROM keiro.keiro_awakeables + WHERE owner_workflow_name = $1 AND owner_workflow_id = $2 + """ + ( contrazip2 + (E.param (E.nonNullable E.text)) + (E.param (E.nonNullable E.text)) + ) + D.noResult deleteChildrenStmt :: Statement (Text, Text, Text, Text) () deleteChildrenStmt = - preparable - """ - DELETE FROM keiro.keiro_workflow_children - WHERE (parent_id = $1 AND parent_name = $2) - OR (child_id = $3 AND child_name = $4) - """ - ( contrazip4 - (E.param (E.nonNullable E.text)) - (E.param (E.nonNullable E.text)) - (E.param (E.nonNullable E.text)) - (E.param (E.nonNullable E.text)) - ) - D.noResult + preparable + """ + DELETE FROM keiro.keiro_workflow_children + WHERE (parent_id = $1 AND parent_name = $2) + OR (child_id = $3 AND child_name = $4) + """ + ( contrazip4 + (E.param (E.nonNullable E.text)) + (E.param (E.nonNullable E.text)) + (E.param (E.nonNullable E.text)) + (E.param (E.nonNullable E.text)) + ) + D.noResult deleteSleepTimersStmt :: Statement (Text, Text, Text) () deleteSleepTimersStmt = - preparable - """ - DELETE FROM keiro.keiro_timers - WHERE correlation_id = $1 - AND process_manager_name = $2 - AND payload->>'kind' = $3 - """ - ( contrazip3 - (E.param (E.nonNullable E.text)) - (E.param (E.nonNullable E.text)) - (E.param (E.nonNullable E.text)) - ) - D.noResult + preparable + """ + DELETE FROM keiro.keiro_timers + WHERE correlation_id = $1 + AND process_manager_name = $2 + AND payload->>'kind' = $3 + """ + ( contrazip3 + (E.param (E.nonNullable E.text)) + (E.param (E.nonNullable E.text)) + (E.param (E.nonNullable E.text)) + ) + D.noResult deleteWorkflowStmt :: Statement (Text, Text) () deleteWorkflowStmt = - preparable - """ - DELETE FROM keiro.keiro_workflows - WHERE workflow_id = $1 AND workflow_name = $2 - """ - ( contrazip2 - (E.param (E.nonNullable E.text)) - (E.param (E.nonNullable E.text)) - ) - D.noResult + preparable + """ + DELETE FROM keiro.keiro_workflows + WHERE workflow_id = $1 AND workflow_name = $2 + """ + ( contrazip2 + (E.param (E.nonNullable E.text)) + (E.param (E.nonNullable E.text)) + ) + D.noResult diff --git a/src/Keiro/Workflow/Instance.hs b/src/Keiro/Workflow/Instance.hs --- a/src/Keiro/Workflow/Instance.hs +++ b/src/Keiro/Workflow/Instance.hs @@ -1,12 +1,11 @@ -{- | Durable workflow instance summaries. - -The journal stream and @keiro_workflow_steps@ index remain the source of truth -for replay. This module maintains one @keiro_workflows@ row per logical -workflow instance so the resume worker can track lifecycle, attempts, and -leases without scanning journal history. --} -module Keiro.Workflow.Instance ( - WorkflowStatus (..), +-- | Durable workflow instance summaries. +-- +-- The journal stream and @keiro_workflow_steps@ index remain the source of truth +-- for replay. This module maintains one @keiro_workflows@ row per logical +-- workflow instance so the resume worker can track lifecycle, attempts, and +-- leases without scanning journal history. +module Keiro.Workflow.Instance + ( WorkflowStatus (..), WorkflowInstanceRow (..), ResurrectOutcome (..), statusToText, @@ -22,7 +21,7 @@ resetInstanceAttempts, reviveFailedInstanceTx, resurrectFailedWorkflow, -) + ) where import Contravariant.Extras (contrazip2, contrazip3, contrazip4, contrazip5) @@ -41,357 +40,355 @@ import "hasql-transaction" Hasql.Transaction qualified as Tx data WorkflowStatus - = WfRunning - | WfSuspended - | WfCompleted - | WfCancelled - | WfFailed - deriving stock (Generic, Eq, Show) + = WfRunning + | WfSuspended + | WfCompleted + | WfCancelled + | WfFailed + deriving stock (Generic, Eq, Show) data WorkflowInstanceRow = WorkflowInstanceRow - { workflowId :: !Text - , workflowName :: !Text - , generation :: !Int32 - , status :: !WorkflowStatus - , attempts :: !Int32 - , lastError :: !(Maybe Text) - , nextAttemptAt :: !(Maybe UTCTime) - , leasedBy :: !(Maybe Text) - , leaseExpiresAt :: !(Maybe UTCTime) - , createdAt :: !UTCTime - , updatedAt :: !UTCTime - , completedAt :: !(Maybe UTCTime) - } - deriving stock (Generic, Eq, Show) + { workflowId :: !Text, + workflowName :: !Text, + generation :: !Int32, + status :: !WorkflowStatus, + attempts :: !Int32, + lastError :: !(Maybe Text), + nextAttemptAt :: !(Maybe UTCTime), + leasedBy :: !(Maybe Text), + leaseExpiresAt :: !(Maybe UTCTime), + createdAt :: !UTCTime, + updatedAt :: !UTCTime, + completedAt :: !(Maybe UTCTime) + } + deriving stock (Generic, Eq, Show) data ResurrectOutcome - = WorkflowResurrected - | WorkflowNotFailed - | WorkflowNotFound - deriving stock (Generic, Eq, Show) + = WorkflowResurrected + | WorkflowNotFailed + | WorkflowNotFound + deriving stock (Generic, Eq, Show) upsertInstanceTx :: Text -> Text -> Int32 -> WorkflowStatus -> Maybe Text -> Tx.Transaction () upsertInstanceTx wid name gen status mLastError = - Tx.statement (wid, name, gen, statusToText status, mLastError) upsertInstanceStmt + Tx.statement (wid, name, gen, statusToText status, mLastError) upsertInstanceStmt markInstanceSuspended :: (Store :> es) => WorkflowName -> WorkflowId -> Eff es () markInstanceSuspended name@(WorkflowName nameText) wid@(WorkflowId widText) = do - gen <- currentGeneration name wid - runTransaction $ - upsertInstanceTx widText nameText (fromIntegral gen) WfSuspended Nothing + gen <- currentGeneration name wid + runTransaction $ + upsertInstanceTx widText nameText (fromIntegral gen) WfSuspended Nothing lookupInstance :: (Store :> es) => WorkflowName -> WorkflowId -> Eff es (Maybe WorkflowInstanceRow) lookupInstance (WorkflowName name) (WorkflowId wid) = - runTransaction (Tx.statement (wid, name) lookupInstanceStmt) + runTransaction (Tx.statement (wid, name) lookupInstanceStmt) claimInstance :: (IOE :> es, Store :> es) => Text -> NominalDiffTime -> WorkflowName -> WorkflowId -> Eff es Bool claimInstance owner ttl name@(WorkflowName nameText) wid@(WorkflowId widText) = do - now <- liftIO getCurrentTime - gen <- currentGeneration name wid - runTransaction $ do - Tx.statement (widText, nameText, fromIntegral gen :: Int32) ensureInstanceStmt - fromMaybe False - <$> Tx.statement - (widText, nameText, owner, now, addUTCTime ttl now) - claimInstanceStmt - -{- | Extend an instance lease only when @owner@ still holds it. + now <- liftIO getCurrentTime + gen <- currentGeneration name wid + runTransaction $ do + Tx.statement (widText, nameText, fromIntegral gen :: Int32) ensureInstanceStmt + fromMaybe False + <$> Tx.statement + (widText, nameText, owner, now, addUTCTime ttl now) + claimInstanceStmt -The caller supplies one clock reading so @updated_at@ and the new expiry share -the same boundary. Returns 'False' after ownership is lost or the row vanishes. --} +-- | Extend an instance lease only when @owner@ still holds it. +-- +-- The caller supplies one clock reading so @updated_at@ and the new expiry share +-- the same boundary. Returns 'False' after ownership is lost or the row vanishes. renewInstanceLeaseTx :: - Text -> - NominalDiffTime -> - UTCTime -> - Text -> - Text -> - Tx.Transaction Bool + Text -> + NominalDiffTime -> + UTCTime -> + Text -> + Text -> + Tx.Transaction Bool renewInstanceLeaseTx owner ttl now wid name = - Tx.statement - (wid, name, owner, now, addUTCTime ttl now) - renewInstanceLeaseStmt + Tx.statement + (wid, name, owner, now, addUTCTime ttl now) + renewInstanceLeaseStmt -- | Effect-level wrapper around 'renewInstanceLeaseTx' using the current time. renewInstanceLease :: - (IOE :> es, Store :> es) => - Text -> - NominalDiffTime -> - WorkflowName -> - WorkflowId -> - Eff es Bool + (IOE :> es, Store :> es) => + Text -> + NominalDiffTime -> + WorkflowName -> + WorkflowId -> + Eff es Bool renewInstanceLease owner ttl (WorkflowName name) (WorkflowId wid) = do - now <- liftIO getCurrentTime - runTransaction (renewInstanceLeaseTx owner ttl now wid name) + now <- liftIO getCurrentTime + runTransaction (renewInstanceLeaseTx owner ttl now wid name) releaseInstance :: (Store :> es) => Text -> Bool -> WorkflowName -> WorkflowId -> Eff es () releaseInstance owner progressed (WorkflowName name) (WorkflowId wid) = - runTransaction $ - Tx.statement (wid, name, owner, progressed) releaseInstanceStmt + runTransaction $ + Tx.statement (wid, name, owner, progressed) releaseInstanceStmt recordCrashTx :: Text -> Text -> Text -> Tx.Transaction Int32 recordCrashTx wid name err = - Tx.statement (wid, name, err) recordCrashStmt + Tx.statement (wid, name, err) recordCrashStmt resetInstanceAttempts :: (Store :> es) => WorkflowName -> WorkflowId -> Eff es () resetInstanceAttempts (WorkflowName name) (WorkflowId wid) = - runTransaction (Tx.statement (wid, name) resetInstanceAttemptsStmt) + runTransaction (Tx.statement (wid, name) resetInstanceAttemptsStmt) reviveFailedInstanceTx :: Text -> Text -> Tx.Transaction Bool reviveFailedInstanceTx wid name = - Tx.statement (wid, name) reviveFailedInstanceStmt - -{- | Return a terminally failed workflow to the runnable pool. + Tx.statement (wid, name) reviveFailedInstanceStmt -The operation removes only the current generation's derived failed-marker index -row; the append-only 'Keiro.Workflow.WorkflowFailed' journal event remains as -history. A failed child link is revived in the same transaction. Parent failure -sentinels already delivered to another journal are not retracted. --} +-- | Return a terminally failed workflow to the runnable pool. +-- +-- The operation removes only the current generation's derived failed-marker index +-- row; the append-only 'Keiro.Workflow.WorkflowFailed' journal event remains as +-- history. A failed child link is revived in the same transaction. Parent failure +-- sentinels already delivered to another journal are not retracted. resurrectFailedWorkflow :: - (Store :> es) => - WorkflowName -> - WorkflowId -> - Eff es ResurrectOutcome + (Store :> es) => + WorkflowName -> + WorkflowId -> + Eff es ResurrectOutcome resurrectFailedWorkflow name@(WorkflowName nameText) wid@(WorkflowId widText) = - lookupInstance name wid >>= \case - Nothing -> pure WorkflowNotFound - Just row - | row ^. #status /= WfFailed -> pure WorkflowNotFailed - | otherwise -> do - gen <- currentGeneration name wid - revived <- - runTransaction $ do - instanceRevived <- reviveFailedInstanceTx widText nameText - when instanceRevived $ do - deleteStepRowTx widText nameText gen failedStepName - void (reviveFailedChildTx widText nameText) - pure instanceRevived - pure $ - if revived - then WorkflowResurrected - else WorkflowNotFailed + lookupInstance name wid >>= \case + Nothing -> pure WorkflowNotFound + Just row + | row ^. #status /= WfFailed -> pure WorkflowNotFailed + | otherwise -> do + gen <- currentGeneration name wid + revived <- + runTransaction $ do + instanceRevived <- reviveFailedInstanceTx widText nameText + when instanceRevived $ do + deleteStepRowTx widText nameText gen failedStepName + void (reviveFailedChildTx widText nameText) + pure instanceRevived + pure $ + if revived + then WorkflowResurrected + else WorkflowNotFailed statusToText :: WorkflowStatus -> Text statusToText = \case - WfRunning -> "running" - WfSuspended -> "suspended" - WfCompleted -> "completed" - WfCancelled -> "cancelled" - WfFailed -> "failed" + WfRunning -> "running" + WfSuspended -> "suspended" + WfCompleted -> "completed" + WfCancelled -> "cancelled" + WfFailed -> "failed" statusFromText :: Text -> WorkflowStatus statusFromText = \case - "running" -> WfRunning - "suspended" -> WfSuspended - "completed" -> WfCompleted - "cancelled" -> WfCancelled - "failed" -> WfFailed - _ -> WfFailed + "running" -> WfRunning + "suspended" -> WfSuspended + "completed" -> WfCompleted + "cancelled" -> WfCancelled + "failed" -> WfFailed + _ -> WfFailed upsertInstanceStmt :: Statement (Text, Text, Int32, Text, Maybe Text) () upsertInstanceStmt = - preparable - """ - INSERT INTO keiro.keiro_workflows - (workflow_id, workflow_name, generation, status, last_error, completed_at) - VALUES ($1, $2, $3, $4, $5, - CASE WHEN $4 IN ('completed', 'cancelled', 'failed') THEN now() ELSE NULL END) - ON CONFLICT (workflow_id, workflow_name) DO UPDATE - SET generation = GREATEST(keiro_workflows.generation, EXCLUDED.generation), - status = EXCLUDED.status, - last_error = EXCLUDED.last_error, - updated_at = now(), - completed_at = CASE - WHEN EXCLUDED.status IN ('completed', 'cancelled', 'failed') - THEN COALESCE(keiro_workflows.completed_at, now()) - ELSE keiro_workflows.completed_at - END - WHERE keiro_workflows.status NOT IN ('completed', 'cancelled', 'failed') - """ - ( contrazip5 - (E.param (E.nonNullable E.text)) - (E.param (E.nonNullable E.text)) - (E.param (E.nonNullable E.int4)) - (E.param (E.nonNullable E.text)) - (E.param (E.nullable E.text)) - ) - D.noResult + preparable + """ + INSERT INTO keiro.keiro_workflows + (workflow_id, workflow_name, generation, status, last_error, completed_at) + VALUES ($1, $2, $3, $4, $5, + CASE WHEN $4 IN ('completed', 'cancelled', 'failed') THEN now() ELSE NULL END) + ON CONFLICT (workflow_id, workflow_name) DO UPDATE + SET generation = GREATEST(keiro_workflows.generation, EXCLUDED.generation), + status = EXCLUDED.status, + last_error = EXCLUDED.last_error, + updated_at = now(), + completed_at = CASE + WHEN EXCLUDED.status IN ('completed', 'cancelled', 'failed') + THEN COALESCE(keiro_workflows.completed_at, now()) + ELSE keiro_workflows.completed_at + END + WHERE keiro_workflows.status NOT IN ('completed', 'cancelled', 'failed') + """ + ( contrazip5 + (E.param (E.nonNullable E.text)) + (E.param (E.nonNullable E.text)) + (E.param (E.nonNullable E.int4)) + (E.param (E.nonNullable E.text)) + (E.param (E.nullable E.text)) + ) + D.noResult lookupInstanceStmt :: Statement (Text, Text) (Maybe WorkflowInstanceRow) lookupInstanceStmt = - preparable - """ - SELECT workflow_id, workflow_name, generation, status, attempts, - last_error, next_attempt_at, leased_by, lease_expires_at, - created_at, updated_at, completed_at - FROM keiro.keiro_workflows - WHERE workflow_id = $1 AND workflow_name = $2 - """ - ( contrazip2 - (E.param (E.nonNullable E.text)) - (E.param (E.nonNullable E.text)) - ) - (D.rowMaybe instanceRowDecoder) + preparable + """ + SELECT workflow_id, workflow_name, generation, status, attempts, + last_error, next_attempt_at, leased_by, lease_expires_at, + created_at, updated_at, completed_at + FROM keiro.keiro_workflows + WHERE workflow_id = $1 AND workflow_name = $2 + """ + ( contrazip2 + (E.param (E.nonNullable E.text)) + (E.param (E.nonNullable E.text)) + ) + (D.rowMaybe instanceRowDecoder) ensureInstanceStmt :: Statement (Text, Text, Int32) () ensureInstanceStmt = - preparable - """ - INSERT INTO keiro.keiro_workflows - (workflow_id, workflow_name, generation, status) - VALUES ($1, $2, $3, 'running') - ON CONFLICT (workflow_id, workflow_name) DO NOTHING - """ - ( contrazip3 - (E.param (E.nonNullable E.text)) - (E.param (E.nonNullable E.text)) - (E.param (E.nonNullable E.int4)) - ) - D.noResult + preparable + """ + INSERT INTO keiro.keiro_workflows + (workflow_id, workflow_name, generation, status) + VALUES ($1, $2, $3, 'running') + ON CONFLICT (workflow_id, workflow_name) DO NOTHING + """ + ( contrazip3 + (E.param (E.nonNullable E.text)) + (E.param (E.nonNullable E.text)) + (E.param (E.nonNullable E.int4)) + ) + D.noResult claimInstanceStmt :: Statement (Text, Text, Text, UTCTime, UTCTime) (Maybe Bool) claimInstanceStmt = - preparable - """ - UPDATE keiro.keiro_workflows - SET leased_by = $3, - lease_expires_at = $5, - updated_at = $4 - WHERE workflow_id = $1 - AND workflow_name = $2 - AND status IN ('running', 'suspended') - AND (lease_expires_at IS NULL OR lease_expires_at < $4) - AND (next_attempt_at IS NULL OR next_attempt_at <= $4) - RETURNING TRUE - """ - ( contrazip5 - (E.param (E.nonNullable E.text)) - (E.param (E.nonNullable E.text)) - (E.param (E.nonNullable E.text)) - (E.param (E.nonNullable E.timestamptz)) - (E.param (E.nonNullable E.timestamptz)) - ) - (D.rowMaybe (D.column (D.nonNullable D.bool))) + preparable + """ + UPDATE keiro.keiro_workflows + SET leased_by = $3, + lease_expires_at = $5, + updated_at = $4 + WHERE workflow_id = $1 + AND workflow_name = $2 + AND status IN ('running', 'suspended') + AND (lease_expires_at IS NULL OR lease_expires_at < $4) + AND (next_attempt_at IS NULL OR next_attempt_at <= $4) + RETURNING TRUE + """ + ( contrazip5 + (E.param (E.nonNullable E.text)) + (E.param (E.nonNullable E.text)) + (E.param (E.nonNullable E.text)) + (E.param (E.nonNullable E.timestamptz)) + (E.param (E.nonNullable E.timestamptz)) + ) + (D.rowMaybe (D.column (D.nonNullable D.bool))) renewInstanceLeaseStmt :: Statement (Text, Text, Text, UTCTime, UTCTime) Bool renewInstanceLeaseStmt = - preparable - """ - UPDATE keiro.keiro_workflows - SET lease_expires_at = $5, - updated_at = $4 - WHERE workflow_id = $1 - AND workflow_name = $2 - AND leased_by = $3 - """ - ( contrazip5 - (E.param (E.nonNullable E.text)) - (E.param (E.nonNullable E.text)) - (E.param (E.nonNullable E.text)) - (E.param (E.nonNullable E.timestamptz)) - (E.param (E.nonNullable E.timestamptz)) - ) - ((> 0) <$> D.rowsAffected) + preparable + """ + UPDATE keiro.keiro_workflows + SET lease_expires_at = $5, + updated_at = $4 + WHERE workflow_id = $1 + AND workflow_name = $2 + AND leased_by = $3 + """ + ( contrazip5 + (E.param (E.nonNullable E.text)) + (E.param (E.nonNullable E.text)) + (E.param (E.nonNullable E.text)) + (E.param (E.nonNullable E.timestamptz)) + (E.param (E.nonNullable E.timestamptz)) + ) + ((> 0) <$> D.rowsAffected) releaseInstanceStmt :: Statement (Text, Text, Text, Bool) () releaseInstanceStmt = - preparable - """ - UPDATE keiro.keiro_workflows - SET leased_by = NULL, - lease_expires_at = NULL, - attempts = CASE WHEN $4 THEN 0 ELSE attempts END, - last_error = CASE WHEN $4 THEN NULL ELSE last_error END, - next_attempt_at = CASE WHEN $4 THEN NULL ELSE next_attempt_at END, - updated_at = now() - WHERE workflow_id = $1 - AND workflow_name = $2 - AND leased_by = $3 - """ - ( contrazip4 - (E.param (E.nonNullable E.text)) - (E.param (E.nonNullable E.text)) - (E.param (E.nonNullable E.text)) - (E.param (E.nonNullable E.bool)) - ) - D.noResult + preparable + """ + UPDATE keiro.keiro_workflows + SET leased_by = NULL, + lease_expires_at = NULL, + attempts = CASE WHEN $4 THEN 0 ELSE attempts END, + last_error = CASE WHEN $4 THEN NULL ELSE last_error END, + next_attempt_at = CASE WHEN $4 THEN NULL ELSE next_attempt_at END, + updated_at = now() + WHERE workflow_id = $1 + AND workflow_name = $2 + AND leased_by = $3 + """ + ( contrazip4 + (E.param (E.nonNullable E.text)) + (E.param (E.nonNullable E.text)) + (E.param (E.nonNullable E.text)) + (E.param (E.nonNullable E.bool)) + ) + D.noResult recordCrashStmt :: Statement (Text, Text, Text) Int32 recordCrashStmt = - preparable - """ - UPDATE keiro.keiro_workflows - SET attempts = attempts + 1, - last_error = $3, - next_attempt_at = now() + (LEAST(power(2, attempts + 1), 64) * interval '1 second'), - updated_at = now() - WHERE workflow_id = $1 - AND workflow_name = $2 - AND status NOT IN ('completed', 'cancelled', 'failed') - RETURNING attempts - """ - ( contrazip3 - (E.param (E.nonNullable E.text)) - (E.param (E.nonNullable E.text)) - (E.param (E.nonNullable E.text)) - ) - (D.singleRow (D.column (D.nonNullable D.int4))) + preparable + """ + UPDATE keiro.keiro_workflows + SET attempts = attempts + 1, + last_error = $3, + next_attempt_at = now() + (LEAST(power(2, attempts + 1), 64) * interval '1 second'), + updated_at = now() + WHERE workflow_id = $1 + AND workflow_name = $2 + AND status NOT IN ('completed', 'cancelled', 'failed') + RETURNING attempts + """ + ( contrazip3 + (E.param (E.nonNullable E.text)) + (E.param (E.nonNullable E.text)) + (E.param (E.nonNullable E.text)) + ) + (D.singleRow (D.column (D.nonNullable D.int4))) resetInstanceAttemptsStmt :: Statement (Text, Text) () resetInstanceAttemptsStmt = - preparable - """ - UPDATE keiro.keiro_workflows - SET attempts = 0, - last_error = NULL, - next_attempt_at = NULL, - updated_at = now() - WHERE workflow_id = $1 - AND workflow_name = $2 - AND status NOT IN ('completed', 'cancelled', 'failed') - """ - ( contrazip2 - (E.param (E.nonNullable E.text)) - (E.param (E.nonNullable E.text)) - ) - D.noResult + preparable + """ + UPDATE keiro.keiro_workflows + SET attempts = 0, + last_error = NULL, + next_attempt_at = NULL, + updated_at = now() + WHERE workflow_id = $1 + AND workflow_name = $2 + AND status NOT IN ('completed', 'cancelled', 'failed') + """ + ( contrazip2 + (E.param (E.nonNullable E.text)) + (E.param (E.nonNullable E.text)) + ) + D.noResult reviveFailedInstanceStmt :: Statement (Text, Text) Bool reviveFailedInstanceStmt = - preparable - """ - UPDATE keiro.keiro_workflows - SET status = 'running', - attempts = 0, - last_error = NULL, - next_attempt_at = NULL, - leased_by = NULL, - lease_expires_at = NULL, - completed_at = NULL, - updated_at = now() - WHERE workflow_id = $1 - AND workflow_name = $2 - AND status = 'failed' - """ - ( contrazip2 - (E.param (E.nonNullable E.text)) - (E.param (E.nonNullable E.text)) - ) - ((> 0) <$> D.rowsAffected) + preparable + """ + UPDATE keiro.keiro_workflows + SET status = 'running', + attempts = 0, + last_error = NULL, + next_attempt_at = NULL, + leased_by = NULL, + lease_expires_at = NULL, + completed_at = NULL, + updated_at = now() + WHERE workflow_id = $1 + AND workflow_name = $2 + AND status = 'failed' + """ + ( contrazip2 + (E.param (E.nonNullable E.text)) + (E.param (E.nonNullable E.text)) + ) + ((> 0) <$> D.rowsAffected) instanceRowDecoder :: D.Row WorkflowInstanceRow instanceRowDecoder = - WorkflowInstanceRow - <$> D.column (D.nonNullable D.text) - <*> D.column (D.nonNullable D.text) - <*> D.column (D.nonNullable D.int4) - <*> (statusFromText <$> D.column (D.nonNullable D.text)) - <*> D.column (D.nonNullable D.int4) - <*> D.column (D.nullable D.text) - <*> D.column (D.nullable D.timestamptz) - <*> D.column (D.nullable D.text) - <*> D.column (D.nullable D.timestamptz) - <*> D.column (D.nonNullable D.timestamptz) - <*> D.column (D.nonNullable D.timestamptz) - <*> D.column (D.nullable D.timestamptz) + WorkflowInstanceRow + <$> D.column (D.nonNullable D.text) + <*> D.column (D.nonNullable D.text) + <*> D.column (D.nonNullable D.int4) + <*> (statusFromText <$> D.column (D.nonNullable D.text)) + <*> D.column (D.nonNullable D.int4) + <*> D.column (D.nullable D.text) + <*> D.column (D.nullable D.timestamptz) + <*> D.column (D.nullable D.text) + <*> D.column (D.nullable D.timestamptz) + <*> D.column (D.nonNullable D.timestamptz) + <*> D.column (D.nonNullable D.timestamptz) + <*> D.column (D.nullable D.timestamptz) diff --git a/src/Keiro/Workflow/Resume.hs b/src/Keiro/Workflow/Resume.hs --- a/src/Keiro/Workflow/Resume.hs +++ b/src/Keiro/Workflow/Resume.hs @@ -1,66 +1,65 @@ -{- | The workflow resume / crash-recovery worker. - -EP-38 makes a workflow replay-on-re-invocation: call 'runWorkflow' (or -'runWorkflowWith') with the same id and each already-journaled step -short-circuits, so only the un-journaled tail runs. But nothing in the runtime -/notices/ that a workflow exists, has steps, and lacks a terminal -'WorkflowCompleted' — i.e. that it crashed mid-run, or is parked on a -@sleep@\/@awakeable@ whose wake source has since resolved. This module is what -notices: a background worker that, on each pass, asks the database "which -workflows have steps but no completion?" ('findUnfinishedWorkflowIds') and -re-invokes each so it proceeds. - -Synchronous exceptions are retried with database-backed exponential backoff. -Once 'maxAttempts' is reached, the worker appends 'WorkflowFailed' and stops -discovering that instance. The operator-facing counterpart lives in -"Keiro.Workflow.Instance": 'Keiro.Workflow.Instance.resurrectFailedWorkflow' -transactionally returns a terminally failed instance to the runnable pool -without deleting its append-only failure history. - -== Why a registry - -A workflow's body is application Haskell code — only its /journal/ (the -recorded step results) lives in the database. To re-invoke a workflow the -worker must turn its stored name into a function -@'WorkflowId' -> 'Eff' ('Workflow' : es) a@. There is no way to materialize a -closure from a string, so the application supplies a 'WorkflowRegistry' mapping -each 'WorkflowName' to its 'WorkflowDef'. This is the resume-worker analogue of -the caller-supplied @fire@ action 'Keiro.Timer.runTimerWorker' takes: the -worker owns the discovery loop and the database access; the application owns -the domain behaviour. - -== Contract recap for downstream plans (the v2 MasterPlan) - -* __'WorkflowRegistry' \/ 'WorkflowDef'__ — the application-supplied - name → definition map. EP-43 (child workflows) relies on this worker to wake - a /parent/ once a child finishes: the child's completion journals the - parent's awaited @child:\@ 'StepRecorded', and the next resume pass - re-invokes the parent (registered here) so it proceeds past its child-wait. -* __'ResumeSummary'__ ('discovered', 'resumed', 'completed', 'stillSuspended', - 'unknownName', 'failed', 'transientErrors', 'leaseSkipped') — the per-pass - observability record. EP-44 reads it for the @keiro.workflow.resumed@ - instrument (and may thread a @Maybe KeiroMetrics@ into - 'WorkflowResumeOptions' \/ 'resumeWorkflowsOnce' following the - no-op-under-@Nothing@ idiom the timer and outbox workers use). -* __'resumeWorkflowsOnce'__ is the single-pass, testable unit (like - 'Keiro.Outbox.publishClaimedOutbox'); __'runWorkflowResumeWorker'__ \/ - __'runWorkflowResumeWorkerWith'__ are the poll-loop drivers (like the - @runTimerWorker@ pair). Re-invocation goes through EP-41's 'runWorkflowWith' - carrying 'runOptions', so a resumed run honours the same snapshot/telemetry - options as its first run. - -Discovery is the 'findUnfinishedWorkflowIds' index query plus the child-row -seed query. Each candidate is claimed through an expiry-based row lease in -@keiro_workflows@ before it is advanced. A live foreign lease skips only that -instance and increments 'leaseSkipped'; a dead worker's lease becomes claimable -after 'leaseTtl'. Each fresh workflow boundary renews the lease before running -side effects. The lease prevents duplicate steady-state work, while the journal -append path still serializes same-step writers so lease expiry races converge -on one recorded result. There is __no kiroku @wf:@ prefix subscription__ and no -session-level advisory lock. --} -module Keiro.Workflow.Resume ( - -- * Registry +-- | The workflow resume / crash-recovery worker. +-- +-- EP-38 makes a workflow replay-on-re-invocation: call 'runWorkflow' (or +-- 'runWorkflowWith') with the same id and each already-journaled step +-- short-circuits, so only the un-journaled tail runs. But nothing in the runtime +-- /notices/ that a workflow exists, has steps, and lacks a terminal +-- 'WorkflowCompleted' — i.e. that it crashed mid-run, or is parked on a +-- @sleep@\/@awakeable@ whose wake source has since resolved. This module is what +-- notices: a background worker that, on each pass, asks the database "which +-- workflows have steps but no completion?" ('findUnfinishedWorkflowIds') and +-- re-invokes each so it proceeds. +-- +-- Synchronous exceptions are retried with database-backed exponential backoff. +-- Once 'maxAttempts' is reached, the worker appends 'WorkflowFailed' and stops +-- discovering that instance. The operator-facing counterpart lives in +-- "Keiro.Workflow.Instance": 'Keiro.Workflow.Instance.resurrectFailedWorkflow' +-- transactionally returns a terminally failed instance to the runnable pool +-- without deleting its append-only failure history. +-- +-- == Why a registry +-- +-- A workflow's body is application Haskell code — only its /journal/ (the +-- recorded step results) lives in the database. To re-invoke a workflow the +-- worker must turn its stored name into a function +-- @'WorkflowId' -> 'Eff' ('Workflow' : es) a@. There is no way to materialize a +-- closure from a string, so the application supplies a 'WorkflowRegistry' mapping +-- each 'WorkflowName' to its 'WorkflowDef'. This is the resume-worker analogue of +-- the caller-supplied @fire@ action 'Keiro.Timer.runTimerWorker' takes: the +-- worker owns the discovery loop and the database access; the application owns +-- the domain behaviour. +-- +-- == Contract recap for downstream plans (the v2 MasterPlan) +-- +-- * __'WorkflowRegistry' \/ 'WorkflowDef'__ — the application-supplied +-- name → definition map. EP-43 (child workflows) relies on this worker to wake +-- a /parent/ once a child finishes: the child's completion journals the +-- parent's awaited @child:\@ 'StepRecorded', and the next resume pass +-- re-invokes the parent (registered here) so it proceeds past its child-wait. +-- * __'ResumeSummary'__ ('discovered', 'resumed', 'completed', 'stillSuspended', +-- 'unknownName', 'failed', 'transientErrors', 'leaseSkipped') — the per-pass +-- observability record. EP-44 reads it for the @keiro.workflow.resumed@ +-- instrument (and may thread a @Maybe KeiroMetrics@ into +-- 'WorkflowResumeOptions' \/ 'resumeWorkflowsOnce' following the +-- no-op-under-@Nothing@ idiom the timer and outbox workers use). +-- * __'resumeWorkflowsOnce'__ is the single-pass, testable unit (like +-- 'Keiro.Outbox.publishClaimedOutbox'); __'runWorkflowResumeWorker'__ \/ +-- __'runWorkflowResumeWorkerWith'__ are the poll-loop drivers (like the +-- @runTimerWorker@ pair). Re-invocation goes through EP-41's 'runWorkflowWith' +-- carrying 'runOptions', so a resumed run honours the same snapshot/telemetry +-- options as its first run. +-- +-- Discovery is the 'findUnfinishedWorkflowIds' index query plus the child-row +-- seed query. Each candidate is claimed through an expiry-based row lease in +-- @keiro_workflows@ before it is advanced. A live foreign lease skips only that +-- instance and increments 'leaseSkipped'; a dead worker's lease becomes claimable +-- after 'leaseTtl'. Each fresh workflow boundary renews the lease before running +-- side effects. The lease prevents duplicate steady-state work, while the journal +-- append path still serializes same-step writers so lease expiry races converge +-- on one recorded result. There is __no kiroku @wf:@ prefix subscription__ and no +-- session-level advisory lock. +module Keiro.Workflow.Resume + ( -- * Registry WorkflowDef (..), WorkflowRegistry, @@ -81,7 +80,7 @@ -- * Running (push-aware, EP-50) runPollLoopWith, runWorkflowResumeWorkerPush, -) + ) where import Control.Concurrent (threadDelay) @@ -101,16 +100,16 @@ import Effectful.Error.Static qualified as Error import Effectful.Exception (catch, catchSync, finally, throwIO) import Keiro.Prelude -import Keiro.Telemetry ( - recordWorkflowAwakeablesPending, +import Keiro.Telemetry + ( recordWorkflowAwakeablesPending, recordWorkflowFailed, recordWorkflowLeaseSkipped, recordWorkflowResumeErrors, recordWorkflowResumed, - ) + ) import Keiro.Wake (WakeSignal (..), wakeSignalFromStore) -import Keiro.Workflow ( - JournalAppendOutcome (..), +import Keiro.Workflow + ( JournalAppendOutcome (..), LeaseHeartbeat (..), Workflow, WorkflowError (..), @@ -126,7 +125,7 @@ findUnfinishedWorkflowIds, prepareJournalAppend, runWorkflowWith, - ) + ) import Keiro.Workflow.Awakeable.Schema (countPendingAwakeables) import Keiro.Workflow.Child (runChildWorkflow) import Keiro.Workflow.Child.Schema (ChildRow, findRunningChildIds, lookupChild, markChildFailedTx) @@ -142,133 +141,127 @@ -- Registry -- --------------------------------------------------------------------------- -{- | How to re-build a workflow's body from its id, for one workflow name. - -The result type @a@ is existential: the worker discards it (it cares only -whether a re-invocation reached 'Completed' or 'Suspended'), so one registry -can hold workflows of different return types. --} +-- | How to re-build a workflow's body from its id, for one workflow name. +-- +-- The result type @a@ is existential: the worker discards it (it cares only +-- whether a re-invocation reached 'Completed' or 'Suspended'), so one registry +-- can hold workflows of different return types. data WorkflowDef es = forall a. (Aeson.ToJSON a) => WorkflowDef - { runDef :: WorkflowId -> Eff (Workflow : es) a - } + { runDef :: WorkflowId -> Eff (Workflow : es) a + } -{- | The application-supplied map from workflow name to its definition. The -worker looks up each discovered workflow's name here; an absent name is -skipped and counted as 'unknownName' (a deploy that dropped a workflow while -instances were still in flight — surfaced, not silently lost). --} +-- | The application-supplied map from workflow name to its definition. The +-- worker looks up each discovered workflow's name here; an absent name is +-- skipped and counted as 'unknownName' (a deploy that dropped a workflow while +-- instances were still in flight — surfaced, not silently lost). type WorkflowRegistry es = Map WorkflowName (WorkflowDef es) -- --------------------------------------------------------------------------- -- Options -- --------------------------------------------------------------------------- -{- | Options for the resume worker. Mirrors the @TimerWorkerOptions@ shape: -'runOptions' threads EP-41's snapshot/telemetry options into 'runWorkflowWith', -and 'pollInterval' is the loop driver's gap between passes. --} +-- | Options for the resume worker. Mirrors the @TimerWorkerOptions@ shape: +-- 'runOptions' threads EP-41's snapshot/telemetry options into 'runWorkflowWith', +-- and 'pollInterval' is the loop driver's gap between passes. data WorkflowResumeOptions = WorkflowResumeOptions - { runOptions :: !WorkflowRunOptions - {- ^ Threaded into 'runWorkflowWith' (or 'runChildWorkflow' for a child) so a - resumed run honours the same snapshot (EP-41) and telemetry (EP-44) - options as its first run. - -} - , pollInterval :: !Int - -- ^ Microseconds the loop driver sleeps between passes. - , maxAttempts :: !Int - -- ^ Workflow-level synchronous exceptions before terminal failure. - , leaseTtl :: !NominalDiffTime - {- ^ How long a claimed workflow instance stays leased without reaching - another fresh workflow boundary. It bounds dead-worker recovery time and - must exceed the longest single step action or await arm. - -} - , logEvent :: !(ResumeLogEvent -> IO ()) - -- ^ Per-worker logging hook. Defaults to a compact stderr renderer. - } - deriving stock (Generic) + { -- | Threaded into 'runWorkflowWith' (or 'runChildWorkflow' for a child) so a + -- resumed run honours the same snapshot (EP-41) and telemetry (EP-44) + -- options as its first run. + runOptions :: !WorkflowRunOptions, + -- | Microseconds the loop driver sleeps between passes. + pollInterval :: !Int, + -- | Workflow-level synchronous exceptions before terminal failure. + maxAttempts :: !Int, + -- | How long a claimed workflow instance stays leased without reaching + -- another fresh workflow boundary. It bounds dead-worker recovery time and + -- must exceed the longest single step action or await arm. + leaseTtl :: !NominalDiffTime, + -- | Per-worker logging hook. Defaults to a compact stderr renderer. + logEvent :: !(ResumeLogEvent -> IO ()) + } + deriving stock (Generic) data ResumeLogEvent - = ResumeUnknownName !Text !Text - | ResumeTransientError !Text !Text !Text - | ResumeWorkflowCrashed !Text !Text !Int !Int !Text - | ResumeWorkflowMarkedFailed !Text !Text !Text - | ResumePassFailed !Text - deriving stock (Eq, Show) + = ResumeUnknownName !Text !Text + | ResumeTransientError !Text !Text !Text + | ResumeWorkflowCrashed !Text !Text !Int !Int !Text + | ResumeWorkflowMarkedFailed !Text !Text !Text + | ResumePassFailed !Text + deriving stock (Eq, Show) -- | Defaults: EP-41's 'defaultWorkflowRunOptions', a 1-second poll, and a 60-second lease. defaultWorkflowResumeOptions :: WorkflowResumeOptions defaultWorkflowResumeOptions = - WorkflowResumeOptions - { runOptions = defaultWorkflowRunOptions - , pollInterval = 1_000_000 - , maxAttempts = 5 - , leaseTtl = 60 - , logEvent = defaultResumeLogEvent - } + WorkflowResumeOptions + { runOptions = defaultWorkflowRunOptions, + pollInterval = 1_000_000, + maxAttempts = 5, + leaseTtl = 60, + logEvent = defaultResumeLogEvent + } defaultResumeLogEvent :: ResumeLogEvent -> IO () defaultResumeLogEvent event = - hPutStrLn stderr $ case event of - ResumeUnknownName name wid -> - "keiro resume worker: no registry entry for workflow " - <> Text.unpack name - <> " (id " - <> Text.unpack wid - <> "); skipping" - ResumeTransientError name wid err -> - "keiro resume worker: transient store error while advancing " - <> Text.unpack name - <> " (id " - <> Text.unpack wid - <> "): " - <> Text.unpack err - ResumeWorkflowCrashed name wid attempt maxAttempt err -> - "keiro resume worker: workflow " - <> Text.unpack name - <> " (id " - <> Text.unpack wid - <> ") crashed on attempt " - <> show attempt - <> "/" - <> show maxAttempt - <> ": " - <> Text.unpack err - ResumeWorkflowMarkedFailed name wid err -> - "keiro resume worker: marked workflow " - <> Text.unpack name - <> " (id " - <> Text.unpack wid - <> ") failed: " - <> Text.unpack err - ResumePassFailed err -> - "keiro resume worker: pass failed: " <> Text.unpack err + hPutStrLn stderr $ case event of + ResumeUnknownName name wid -> + "keiro resume worker: no registry entry for workflow " + <> Text.unpack name + <> " (id " + <> Text.unpack wid + <> "); skipping" + ResumeTransientError name wid err -> + "keiro resume worker: transient store error while advancing " + <> Text.unpack name + <> " (id " + <> Text.unpack wid + <> "): " + <> Text.unpack err + ResumeWorkflowCrashed name wid attempt maxAttempt err -> + "keiro resume worker: workflow " + <> Text.unpack name + <> " (id " + <> Text.unpack wid + <> ") crashed on attempt " + <> show attempt + <> "/" + <> show maxAttempt + <> ": " + <> Text.unpack err + ResumeWorkflowMarkedFailed name wid err -> + "keiro resume worker: marked workflow " + <> Text.unpack name + <> " (id " + <> Text.unpack wid + <> ") failed: " + <> Text.unpack err + ResumePassFailed err -> + "keiro resume worker: pass failed: " <> Text.unpack err -- --------------------------------------------------------------------------- -- Per-pass summary -- --------------------------------------------------------------------------- -{- | What one 'resumeWorkflowsOnce' pass did. EP-44 instruments this for -@keiro.workflow.resumed@. --} +-- | What one 'resumeWorkflowsOnce' pass did. EP-44 instruments this for +-- @keiro.workflow.resumed@. data ResumeSummary = ResumeSummary - { discovered :: !Int - -- ^ Unfinished workflows 'findUnfinishedWorkflowIds' returned this pass. - , resumed :: !Int - -- ^ Workflows re-invoked (found in the registry and run). - , completed :: !Int - -- ^ Re-invocations that reached 'Completed' this pass. - , stillSuspended :: !Int - -- ^ Re-invocations that returned 'Suspended' (wake source not yet resolved). - , unknownName :: !Int - -- ^ Discovered workflows whose name was absent from the registry (skipped + logged). - , failed :: !Int - -- ^ Workflows marked terminally failed this pass. - , transientErrors :: !Int - -- ^ Store errors observed while advancing individual workflows. - , leaseSkipped :: !Int - -- ^ Candidates skipped because another worker holds a live lease. - } - deriving stock (Generic, Eq, Show) + { -- | Unfinished workflows 'findUnfinishedWorkflowIds' returned this pass. + discovered :: !Int, + -- | Workflows re-invoked (found in the registry and run). + resumed :: !Int, + -- | Re-invocations that reached 'Completed' this pass. + completed :: !Int, + -- | Re-invocations that returned 'Suspended' (wake source not yet resolved). + stillSuspended :: !Int, + -- | Discovered workflows whose name was absent from the registry (skipped + logged). + unknownName :: !Int, + -- | Workflows marked terminally failed this pass. + failed :: !Int, + -- | Store errors observed while advancing individual workflows. + transientErrors :: !Int, + -- | Candidates skipped because another worker holds a live lease. + leaseSkipped :: !Int + } + deriving stock (Generic, Eq, Show) -- | A zeroed 'ResumeSummary'. emptyResumeSummary :: ResumeSummary @@ -278,45 +271,44 @@ -- Running -- --------------------------------------------------------------------------- -{- | Run one discover-and-reinvoke pass. - -Discovers every unfinished workflow via 'findUnfinishedWorkflowIds', and for -each looks its name up in @registry@: - -* __present__ — re-invoke through 'runWorkflowWith' (the journal pre-load - short-circuits already-journaled steps, so only the un-journaled tail runs); - the outcome bumps 'completed' or 'stillSuspended'. -* __absent__ — log a warning and bump 'unknownName' (a workflow whose code was - removed while instances were in flight must be visible, not silently lost). - -Idempotent: a completed workflow has a @__workflow_completed__@ index row and -so drops out of discovery; re-invoking an unfinished one twice converges to the -same journal (EP-38 deterministic ids + step short-circuit). --} +-- | Run one discover-and-reinvoke pass. +-- +-- Discovers every unfinished workflow via 'findUnfinishedWorkflowIds', and for +-- each looks its name up in @registry@: +-- +-- * __present__ — re-invoke through 'runWorkflowWith' (the journal pre-load +-- short-circuits already-journaled steps, so only the un-journaled tail runs); +-- the outcome bumps 'completed' or 'stillSuspended'. +-- * __absent__ — log a warning and bump 'unknownName' (a workflow whose code was +-- removed while instances were in flight must be visible, not silently lost). +-- +-- Idempotent: a completed workflow has a @__workflow_completed__@ index row and +-- so drops out of discovery; re-invoking an unfinished one twice converges to the +-- same journal (EP-38 deterministic ids + step short-circuit). resumeWorkflowsOnce :: - forall es. - (IOE :> es, Store :> es, Error StoreError :> es) => - WorkflowResumeOptions -> - WorkflowRegistry es -> - Eff es ResumeSummary + forall es. + (IOE :> es, Store :> es, Error StoreError :> es) => + WorkflowResumeOptions -> + WorkflowRegistry es -> + Eff es ResumeSummary resumeWorkflowsOnce opts registry = do - -- EP-44: sample the @keiro.workflow.awakeables.pending@ gauge once per pass, - -- on the same Store the discovery query uses. The metrics handle rides on the - -- run options (EP-44 threads telemetry through 'WorkflowRunOptions'), so it is - -- already forwarded into 'runWorkflowWith' for every re-invocation. - pending <- countPendingAwakeables - recordWorkflowAwakeablesPending mMetrics (fromIntegral pending) - -- Discovery unions two sources: workflows with steps but no terminal marker - -- ('findUnfinishedWorkflowIds') and freshly-spawned children that have no - -- step rows yet ('findRunningChildIds', EP-43) — so a zero-step child is - -- still driven. The dedup collapses a child that appears in both. - now <- liftIO getCurrentTime - unfinished <- findUnfinishedWorkflowIds now - runningChildren <- findRunningChildIds - let pairs = dedupeFirstSeen (unfinished <> runningChildren) - seed = emptyResumeSummary{discovered = length pairs} - owner <- UUID.toText <$> liftIO UUIDv4.nextRandom - foldM (advance owner) seed pairs + -- EP-44: sample the @keiro.workflow.awakeables.pending@ gauge once per pass, + -- on the same Store the discovery query uses. The metrics handle rides on the + -- run options (EP-44 threads telemetry through 'WorkflowRunOptions'), so it is + -- already forwarded into 'runWorkflowWith' for every re-invocation. + pending <- countPendingAwakeables + recordWorkflowAwakeablesPending mMetrics (fromIntegral pending) + -- Discovery unions two sources: workflows with steps but no terminal marker + -- ('findUnfinishedWorkflowIds') and freshly-spawned children that have no + -- step rows yet ('findRunningChildIds', EP-43) — so a zero-step child is + -- still driven. The dedup collapses a child that appears in both. + now <- liftIO getCurrentTime + unfinished <- findUnfinishedWorkflowIds now + runningChildren <- findRunningChildIds + let pairs = dedupeFirstSeen (unfinished <> runningChildren) + seed = emptyResumeSummary {discovered = length pairs} + owner <- UUID.toText <$> liftIO UUIDv4.nextRandom + foldM (advance owner) seed pairs where mMetrics = runOptions opts ^. #metrics dedupeFirstSeen :: [(Text, Text)] -> [(Text, Text)] @@ -324,241 +316,237 @@ where go !_ [] = [] go !seen (pair : rest) - | pair `Set.member` seen = go seen rest - | otherwise = pair : go (Set.insert pair seen) rest + | pair `Set.member` seen = go seen rest + | otherwise = pair : go (Set.insert pair seen) rest advance :: Text -> ResumeSummary -> (Text, Text) -> Eff es ResumeSummary advance owner acc (widText, wnameText) = - case Map.lookup (WorkflowName wnameText) registry of - Nothing -> do - liftIO $ logEvent opts (ResumeUnknownName wnameText widText) - pure acc{unknownName = unknownName acc + 1} - Just (WorkflowDef runDef) -> do - let wid = WorkflowId widText - name = WorkflowName wnameText - claimed <- claimInstance owner (leaseTtl opts) name wid - if not claimed - then do - recordWorkflowLeaseSkipped mMetrics 1 - pure acc{leaseSkipped = leaseSkipped acc + 1} - else do - progressedRef <- liftIO (newIORef False) - ( do - attempt <- - Error.catchError - @StoreError - (AdvOk <$> driveInstance owner name wid runDef) - (\_ e -> pure (AdvTransient e)) - `catch` (\WorkflowLeaseLost -> pure AdvLeaseLost) - `catchSync` (pure . AdvCrashed) - recordWorkflowResumed mMetrics 1 - (acc', progressed) <- handleAttempt acc name wid attempt - liftIO (writeIORef progressedRef progressed) - pure acc' - ) - `finally` do - progressed <- liftIO (readIORef progressedRef) - releaseInstance owner progressed name wid + case Map.lookup (WorkflowName wnameText) registry of + Nothing -> do + liftIO $ logEvent opts (ResumeUnknownName wnameText widText) + pure acc {unknownName = unknownName acc + 1} + Just (WorkflowDef runDef) -> do + let wid = WorkflowId widText + name = WorkflowName wnameText + claimed <- claimInstance owner (leaseTtl opts) name wid + if not claimed + then do + recordWorkflowLeaseSkipped mMetrics 1 + pure acc {leaseSkipped = leaseSkipped acc + 1} + else do + progressedRef <- liftIO (newIORef False) + ( do + attempt <- + Error.catchError + @StoreError + (AdvOk <$> driveInstance owner name wid runDef) + (\_ e -> pure (AdvTransient e)) + `catch` (\WorkflowLeaseLost -> pure AdvLeaseLost) + `catchSync` (pure . AdvCrashed) + recordWorkflowResumed mMetrics 1 + (acc', progressed) <- handleAttempt acc name wid attempt + liftIO (writeIORef progressedRef progressed) + pure acc' + ) + `finally` do + progressed <- liftIO (readIORef progressedRef) + releaseInstance owner progressed name wid driveInstance :: (Aeson.ToJSON a) => Text -> WorkflowName -> WorkflowId -> (WorkflowId -> Eff (Workflow : es) a) -> Eff es (WorkflowOutcome a) driveInstance owner name@(WorkflowName wnameText) wid@(WorkflowId widText) runDef = do - mChild <- lookupChild widText wnameText - let runOpts = - runOptions opts - & #leaseHeartbeat - .~ Just LeaseHeartbeat{owner, ttl = leaseTtl opts} - case mChild of - Just _ -> runChildWorkflow runOpts name wid (runDef wid) - Nothing -> runWorkflowWith runOpts name wid (runDef wid) + mChild <- lookupChild widText wnameText + let runOpts = + runOptions opts + & #leaseHeartbeat + .~ Just LeaseHeartbeat {owner, ttl = leaseTtl opts} + case mChild of + Just _ -> runChildWorkflow runOpts name wid (runDef wid) + Nothing -> runWorkflowWith runOpts name wid (runDef wid) handleAttempt :: ResumeSummary -> WorkflowName -> WorkflowId -> AdvanceResult a -> Eff es (ResumeSummary, Bool) handleAttempt acc name@(WorkflowName wnameText) wid@(WorkflowId widText) = \case - AdvOk outcome -> do - pure (bumpForOutcome outcome acc, True) - AdvTransient err -> do - let rendered = Text.pack (show err) - liftIO $ logEvent opts (ResumeTransientError wnameText widText rendered) - recordWorkflowResumeErrors mMetrics 1 - pure (acc{resumed = resumed acc + 1, transientErrors = transientErrors acc + 1}, False) - AdvLeaseLost -> do - recordWorkflowLeaseSkipped mMetrics 1 - pure (acc{leaseSkipped = leaseSkipped acc + 1}, False) - AdvCrashed err -> do - let rendered = Text.pack (show err) - attempt <- runTransaction (recordCrashTx widText wnameText rendered) - liftIO $ logEvent opts (ResumeWorkflowCrashed wnameText widText (fromIntegral attempt) (maxAttempts opts) rendered) - if attempt >= fromIntegral (maxAttempts opts :: Int) - then do - now <- liftIO getCurrentTime - mChild <- lookupChild widText wnameText - case mChild of - Nothing -> - appendJournalEntry name wid (WorkflowFailed rendered now) - Just childRow -> - appendFailedChildAndWakeParent name wid rendered now childRow - liftIO $ logEvent opts (ResumeWorkflowMarkedFailed wnameText widText rendered) - recordWorkflowFailed mMetrics 1 - pure (acc{resumed = resumed acc + 1, failed = failed acc + 1}, False) - else pure (acc{resumed = resumed acc + 1}, False) + AdvOk outcome -> do + pure (bumpForOutcome outcome acc, True) + AdvTransient err -> do + let rendered = Text.pack (show err) + liftIO $ logEvent opts (ResumeTransientError wnameText widText rendered) + recordWorkflowResumeErrors mMetrics 1 + pure (acc {resumed = resumed acc + 1, transientErrors = transientErrors acc + 1}, False) + AdvLeaseLost -> do + recordWorkflowLeaseSkipped mMetrics 1 + pure (acc {leaseSkipped = leaseSkipped acc + 1}, False) + AdvCrashed err -> do + let rendered = Text.pack (show err) + attempt <- runTransaction (recordCrashTx widText wnameText rendered) + liftIO $ logEvent opts (ResumeWorkflowCrashed wnameText widText (fromIntegral attempt) (maxAttempts opts) rendered) + if attempt >= fromIntegral (maxAttempts opts :: Int) + then do + now <- liftIO getCurrentTime + mChild <- lookupChild widText wnameText + case mChild of + Nothing -> + appendJournalEntry name wid (WorkflowFailed rendered now) + Just childRow -> + appendFailedChildAndWakeParent name wid rendered now childRow + liftIO $ logEvent opts (ResumeWorkflowMarkedFailed wnameText widText rendered) + recordWorkflowFailed mMetrics 1 + pure (acc {resumed = resumed acc + 1, failed = failed acc + 1}, False) + else pure (acc {resumed = resumed acc + 1}, False) data AdvanceResult a - = AdvOk !(WorkflowOutcome a) - | AdvTransient !StoreError - | AdvLeaseLost - | AdvCrashed !Exception.SomeException + = AdvOk !(WorkflowOutcome a) + | AdvTransient !StoreError + | AdvLeaseLost + | AdvCrashed !Exception.SomeException appendFailedChildAndWakeParent :: - (IOE :> es, Store :> es) => - WorkflowName -> - WorkflowId -> - Text -> - UTCTime -> - ChildRow -> - Eff es () + (IOE :> es, Store :> es) => + WorkflowName -> + WorkflowId -> + Text -> + UTCTime -> + ChildRow -> + Eff es () appendFailedChildAndWakeParent childNm childWid reason now childRow = do - childGen <- currentGeneration childNm childWid - let parentNm = WorkflowName (childRow ^. #parentName) - parentWid = WorkflowId (childRow ^. #parentId) - parentGen <- currentGeneration parentNm parentWid - childFailTx <- prepareJournalAppend childNm childWid childGen (WorkflowFailed reason now) - parentWakeTx <- - prepareJournalAppend - parentNm - parentWid - parentGen - StepRecorded - { stepName = childRow ^. #awaitStep - , result = Aeson.object ["failed" Aeson..= reason] - , recordedAt = now - } - (childOutcome, parentOutcome) <- - runTransaction $ do - childOutcome <- childFailTx - _transitioned <- markChildFailedTx (unWorkflowId childWid) (unWorkflowName childNm) reason - parentOutcome <- parentWakeTx - condemnOnAppendConflict childOutcome - condemnOnAppendConflict parentOutcome - pure (childOutcome, parentOutcome) - throwOnAppendConflict childOutcome - throwOnAppendConflict parentOutcome + childGen <- currentGeneration childNm childWid + let parentNm = WorkflowName (childRow ^. #parentName) + parentWid = WorkflowId (childRow ^. #parentId) + parentGen <- currentGeneration parentNm parentWid + childFailTx <- prepareJournalAppend childNm childWid childGen (WorkflowFailed reason now) + parentWakeTx <- + prepareJournalAppend + parentNm + parentWid + parentGen + StepRecorded + { stepName = childRow ^. #awaitStep, + result = Aeson.object ["failed" Aeson..= reason], + recordedAt = now + } + (childOutcome, parentOutcome) <- + runTransaction $ do + childOutcome <- childFailTx + _transitioned <- markChildFailedTx (unWorkflowId childWid) (unWorkflowName childNm) reason + parentOutcome <- parentWakeTx + condemnOnAppendConflict childOutcome + condemnOnAppendConflict parentOutcome + pure (childOutcome, parentOutcome) + throwOnAppendConflict childOutcome + throwOnAppendConflict parentOutcome condemnOnAppendConflict :: JournalAppendOutcome -> Tx.Transaction () condemnOnAppendConflict = \case - JournalAppendConflict{} -> Tx.condemn - _ -> pure () + JournalAppendConflict {} -> Tx.condemn + _ -> pure () throwOnAppendConflict :: JournalAppendOutcome -> Eff es () throwOnAppendConflict = \case - JournalAppendConflict err -> throwIO (WorkflowJournalAppendError (Text.pack (show err))) - _ -> pure () + JournalAppendConflict err -> throwIO (WorkflowJournalAppendError (Text.pack (show err))) + _ -> pure () -{- | Fold one re-invocation's outcome into the running summary. The existential -result @a@ is discarded here, so it never escapes the registry. --} +-- | Fold one re-invocation's outcome into the running summary. The existential +-- result @a@ is discarded here, so it never escapes the registry. bumpForOutcome :: WorkflowOutcome a -> ResumeSummary -> ResumeSummary bumpForOutcome outcome acc = case outcome of - Completed _ -> acc{resumed = resumed acc + 1, completed = completed acc + 1} - Suspended -> acc{resumed = resumed acc + 1, stillSuspended = stillSuspended acc + 1} - -- A workflow cancelled between discovery and re-invocation short-circuits to - -- 'Cancelled' (EP-43); count it as re-invoked but neither completed nor - -- suspended. (A cancelled workflow also drops out of discovery, so this is a - -- rare race, not the steady state.) - Cancelled -> acc{resumed = resumed acc + 1} - Failed -> acc{resumed = resumed acc + 1} - -- A workflow that rotated via continueAsNew (EP-48) returns 'ContinuedAsNew': - -- it is re-invoked but neither completed nor suspended this pass. Its new - -- generation has no terminal marker, so 'findUnfinishedWorkflowIds' still - -- reports it and the next pass drives the rotated generation forward. - ContinuedAsNew -> acc{resumed = resumed acc + 1} + Completed _ -> acc {resumed = resumed acc + 1, completed = completed acc + 1} + Suspended -> acc {resumed = resumed acc + 1, stillSuspended = stillSuspended acc + 1} + -- A workflow cancelled between discovery and re-invocation short-circuits to + -- 'Cancelled' (EP-43); count it as re-invoked but neither completed nor + -- suspended. (A cancelled workflow also drops out of discovery, so this is a + -- rare race, not the steady state.) + Cancelled -> acc {resumed = resumed acc + 1} + Failed -> acc {resumed = resumed acc + 1} + -- A workflow that rotated via continueAsNew (EP-48) returns 'ContinuedAsNew': + -- it is re-invoked but neither completed nor suspended this pass. Its new + -- generation has no terminal marker, so 'findUnfinishedWorkflowIds' still + -- reports it and the next pass drives the rotated generation forward. + ContinuedAsNew -> acc {resumed = resumed acc + 1} -{- | Poll-and-resume loop: run 'resumeWorkflowsOnce' on the configured -'pollInterval' forever. Mirrors how an application schedules -'Keiro.Outbox.publishClaimedOutbox' \/ @runTimerWorker@ per tick; the -single-pass 'resumeWorkflowsOnce' remains the testable unit. --} +-- | Poll-and-resume loop: run 'resumeWorkflowsOnce' on the configured +-- 'pollInterval' forever. Mirrors how an application schedules +-- 'Keiro.Outbox.publishClaimedOutbox' \/ @runTimerWorker@ per tick; the +-- single-pass 'resumeWorkflowsOnce' remains the testable unit. runWorkflowResumeWorkerWith :: - (IOE :> es, Store :> es, Error StoreError :> es) => - WorkflowResumeOptions -> - WorkflowRegistry es -> - Eff es () + (IOE :> es, Store :> es, Error StoreError :> es) => + WorkflowResumeOptions -> + WorkflowRegistry es -> + Eff es () runWorkflowResumeWorkerWith opts registry = forever $ do - _summary <- - (Just <$> resumeWorkflowsOnce opts registry) - `Error.catchError` (\_ (e :: StoreError) -> logPass (Text.pack (show e))) - `catchSync` (logPass . Text.pack . show) - liftIO (threadDelay (pollInterval opts)) + _summary <- + (Just <$> resumeWorkflowsOnce opts registry) + `Error.catchError` (\_ (e :: StoreError) -> logPass (Text.pack (show e))) + `catchSync` (logPass . Text.pack . show) + liftIO (threadDelay (pollInterval opts)) where logPass msg = do - liftIO $ logEvent opts (ResumePassFailed msg) - pure Nothing + liftIO $ logEvent opts (ResumePassFailed msg) + pure Nothing -- | 'runWorkflowResumeWorkerWith' with 'defaultWorkflowResumeOptions'. runWorkflowResumeWorker :: - (IOE :> es, Store :> es, Error StoreError :> es) => - WorkflowRegistry es -> - Eff es () + (IOE :> es, Store :> es, Error StoreError :> es) => + WorkflowRegistry es -> + Eff es () runWorkflowResumeWorker = runWorkflowResumeWorkerWith defaultWorkflowResumeOptions -- --------------------------------------------------------------------------- -- Push-aware loop (EP-50) -- --------------------------------------------------------------------------- -{- | Generic push-aware poll loop: run one pass, then block on the 'WakeSignal' -with the given fallback timeout (microseconds), forever. The pass is the durable -unit; the wake only shortens the gap between passes. Both wake reasons (a -notification or the fallback elapsing) mean "run another pass", so the returned -'Keiro.Wake.WakeReason' is ignored for control flow. A missed @NOTIFY@ costs at -most one fallback interval of latency, never lost work — correctness rests on the -pass (e.g. 'resumeWorkflowsOnce'), which is idempotent, not on a notification -arriving. The same pattern applies mechanically to 'Keiro.Timer.runTimerWorker' -and 'Keiro.Outbox.publishClaimedOutbox' (documented, not implemented here; the -resume worker carries the acceptance via parent/child cascades). --} +-- | Generic push-aware poll loop: run one pass, then block on the 'WakeSignal' +-- with the given fallback timeout (microseconds), forever. The pass is the durable +-- unit; the wake only shortens the gap between passes. Both wake reasons (a +-- notification or the fallback elapsing) mean "run another pass", so the returned +-- 'Keiro.Wake.WakeReason' is ignored for control flow. A missed @NOTIFY@ costs at +-- most one fallback interval of latency, never lost work — correctness rests on the +-- pass (e.g. 'resumeWorkflowsOnce'), which is idempotent, not on a notification +-- arriving. The same pattern applies mechanically to 'Keiro.Timer.runTimerWorker' +-- and 'Keiro.Outbox.publishClaimedOutbox' (documented, not implemented here; the +-- resume worker carries the acceptance via parent/child cascades). runPollLoopWith :: - -- | the wake signal to block on between passes - WakeSignal -> - -- | fallback timeout in microseconds (the maximum gap when no notification arrives) - Int -> - -- | one pass, already wrapped to run in 'IO' - IO () -> - IO () + -- | the wake signal to block on between passes + WakeSignal -> + -- | fallback timeout in microseconds (the maximum gap when no notification arrives) + Int -> + -- | one pass, already wrapped to run in 'IO' + IO () -> + IO () runPollLoopWith wake fallbackMicros pass = - forever (pass >> void (waitForWake wake fallbackMicros)) - -{- | The workflow resume worker, push-aware (EP-50). Runs 'resumeWorkflowsOnce' -on each pass; between passes it waits on the store's notifier (sub-second wake on -any append) and falls back to 'pollInterval' so a dropped notification still -drains the backlog. - -This is the push-aware sibling of 'runWorkflowResumeWorker' / -'runWorkflowResumeWorkerWith', which remain unchanged as the durable fixed-poll -baseline. The 'pollInterval' field is __repurposed__ as the /fallback/ timeout: -its meaning shifts from "fixed gap between passes" to "maximum gap when no -notification arrives" — strictly better for latency, identical in the -no-notification worst case. + forever (pass >> void (waitForWake wake fallbackMicros)) -It opens __no__ new database connection (the 'WakeSignal' rides kiroku's existing -single per-store listener; see "Keiro.Wake"). It takes the 'KirokuStore' handle -directly to reach that notifier, and runs each pass through -'Kiroku.Store.Effect.runStoreIO', which pins the registry's effect row to the -concrete @'[Store, Error StoreError, IOE]@ that @runStoreIO@ eliminates. A caller -needing a richer effect row can use 'runPollLoopWith' directly with their own -@runStoreIO@-equivalent pass. --} +-- | The workflow resume worker, push-aware (EP-50). Runs 'resumeWorkflowsOnce' +-- on each pass; between passes it waits on the store's notifier (sub-second wake on +-- any append) and falls back to 'pollInterval' so a dropped notification still +-- drains the backlog. +-- +-- This is the push-aware sibling of 'runWorkflowResumeWorker' / +-- 'runWorkflowResumeWorkerWith', which remain unchanged as the durable fixed-poll +-- baseline. The 'pollInterval' field is __repurposed__ as the /fallback/ timeout: +-- its meaning shifts from "fixed gap between passes" to "maximum gap when no +-- notification arrives" — strictly better for latency, identical in the +-- no-notification worst case. +-- +-- It opens __no__ new database connection (the 'WakeSignal' rides kiroku's existing +-- single per-store listener; see "Keiro.Wake"). It takes the 'KirokuStore' handle +-- directly to reach that notifier, and runs each pass through +-- 'Kiroku.Store.Effect.runStoreIO', which pins the registry's effect row to the +-- concrete @'[Store, Error StoreError, IOE]@ that @runStoreIO@ eliminates. A caller +-- needing a richer effect row can use 'runPollLoopWith' directly with their own +-- @runStoreIO@-equivalent pass. runWorkflowResumeWorkerPush :: - KirokuStore -> - WorkflowResumeOptions -> - WorkflowRegistry '[Store, Error StoreError, IOE] -> - IO () + KirokuStore -> + WorkflowResumeOptions -> + WorkflowRegistry '[Store, Error StoreError, IOE] -> + IO () runWorkflowResumeWorkerPush store opts registry = do - wake <- wakeSignalFromStore store - runPollLoopWith wake (pollInterval opts) onePass + wake <- wakeSignalFromStore store + runPollLoopWith wake (pollInterval opts) onePass where onePass = - handleSyncIO $ - runStoreIO store (resumeWorkflowsOnce opts registry) >>= \case - Left err -> logEvent opts (ResumePassFailed (Text.pack (show err))) - Right _ -> pure () + handleSyncIO $ + runStoreIO store (resumeWorkflowsOnce opts registry) >>= \case + Left err -> logEvent opts (ResumePassFailed (Text.pack (show err))) + Right _ -> pure () handleSyncIO action = - action `Exception.catch` \err -> - case Exception.fromException err of - Just (async :: Exception.SomeAsyncException) -> Exception.throwIO async - Nothing -> logEvent opts (ResumePassFailed (Text.pack (show (err :: Exception.SomeException)))) + action `Exception.catch` \err -> + case Exception.fromException err of + Just (async :: Exception.SomeAsyncException) -> Exception.throwIO async + Nothing -> logEvent opts (ResumePassFailed (Text.pack (show (err :: Exception.SomeException)))) diff --git a/src/Keiro/Workflow/Schema.hs b/src/Keiro/Workflow/Schema.hs --- a/src/Keiro/Workflow/Schema.hs +++ b/src/Keiro/Workflow/Schema.hs @@ -1,18 +1,17 @@ -{- | 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 +-- | 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 @@ -29,7 +28,7 @@ stepExists, currentGeneration, findUnfinishedWorkflowIds, -) + ) where import Contravariant.Extras (contrazip2, contrazip3, contrazip4, contrazip6) @@ -46,221 +45,213 @@ import Kiroku.Store.Transaction (runTransaction) import "hasql-transaction" Hasql.Transaction qualified as Tx -{- | A row of the @keiro_workflow_steps@ index: the workflow instance and -name, the step name, the step's JSON result, and when it was recorded. The -terminal completion marker is stored as a row whose 'stepName' is -'Keiro.Workflow.Types.completedStepName' and whose 'result' is JSON @null@. --} +-- | A row of the @keiro_workflow_steps@ index: the workflow instance and +-- name, the step name, the step's JSON result, and when it was recorded. The +-- terminal completion marker is stored as a row whose 'stepName' is +-- 'Keiro.Workflow.Types.completedStepName' and whose 'result' is JSON @null@. data WorkflowStepRow = WorkflowStepRow - { workflowId :: !Text - , workflowName :: !Text - , generation :: !Int - {- ^ EP-48: the journal /generation/ this step belongs to. Generation 0 is - the pre-rotation default; @continueAsNew@ rotates onto higher generations. - -} - , stepName :: !Text - , result :: !Value - , recordedAt :: !UTCTime - } - deriving stock (Generic, Eq, Show) + { workflowId :: !Text, + workflowName :: !Text, + -- | EP-48: the journal /generation/ this step belongs to. Generation 0 is + -- the pre-rotation default; @continueAsNew@ rotates onto higher generations. + generation :: !Int, + stepName :: !Text, + result :: !Value, + recordedAt :: !UTCTime + } + deriving stock (Generic, Eq, Show) -{- | Upsert a step row inside the caller's transaction — an -@INSERT ... ON CONFLICT (workflow_id, step_name) DO NOTHING@, so a replayed -or raced write is a no-op. Called in the same transaction as the journal -append so the index and the journal stay consistent. --} +-- | Upsert a step row inside the caller's transaction — an +-- @INSERT ... ON CONFLICT (workflow_id, step_name) DO NOTHING@, so a replayed +-- or raced write is a no-op. Called in the same transaction as the journal +-- append so the index and the journal stay consistent. recordStepTx :: WorkflowStepRow -> Tx.Transaction () recordStepTx row = - Tx.statement - ( row ^. #workflowId - , row ^. #workflowName - , fromIntegral (row ^. #generation) :: Int32 - , row ^. #stepName - , row ^. #result - , row ^. #recordedAt - ) - recordStepStmt + Tx.statement + ( row ^. #workflowId, + row ^. #workflowName, + fromIntegral (row ^. #generation) :: Int32, + row ^. #stepName, + row ^. #result, + row ^. #recordedAt + ) + recordStepStmt lookupStepResultTx :: Text -> Text -> Int -> Text -> Tx.Transaction (Maybe Value) lookupStepResultTx wid name gen key = - Tx.statement (wid, name, fromIntegral gen :: Int32, key) lookupStepResultStmt + Tx.statement (wid, name, fromIntegral gen :: Int32, key) lookupStepResultStmt lockWorkflowStepTx :: Text -> Tx.Transaction () lockWorkflowStepTx key = - void (Tx.statement key lockWorkflowStepStmt) + void (Tx.statement key lockWorkflowStepStmt) deleteStepRowTx :: Text -> Text -> Int -> Text -> Tx.Transaction () deleteStepRowTx wid name gen key = - Tx.statement - (wid, name, fromIntegral gen :: Int32, key) - deleteStepRowStmt + Tx.statement + (wid, name, fromIntegral gen :: Int32, key) + deleteStepRowStmt setWorkflowWakeAfterTx :: WorkflowName -> WorkflowId -> UTCTime -> Tx.Transaction () setWorkflowWakeAfterTx (WorkflowName name) (WorkflowId wid) wakeAfter = - Tx.statement (wid, name, wakeAfter) setWorkflowWakeAfterStmt + Tx.statement (wid, name, wakeAfter) setWorkflowWakeAfterStmt clearWorkflowWakeAfterTx :: WorkflowName -> WorkflowId -> Tx.Transaction () clearWorkflowWakeAfterTx (WorkflowName name) (WorkflowId wid) = - Tx.statement (wid, name) clearWorkflowWakeAfterStmt + Tx.statement (wid, name) clearWorkflowWakeAfterStmt -{- | Load every recorded step for a workflow instance as a @step name -> -result@ map (includes the terminal completion marker row if present). Exposed -for EP-42's resume worker; the replay handler in "Keiro.Workflow" pre-loads -from the journal stream instead. --} +-- | Load every recorded step for a workflow instance as a @step name -> +-- result@ map (includes the terminal completion marker row if present). Exposed +-- for EP-42's resume worker; the replay handler in "Keiro.Workflow" pre-loads +-- from the journal stream instead. loadStepIndex :: (Store :> es) => WorkflowName -> WorkflowId -> Int -> Eff es (Map Text Value) loadStepIndex (WorkflowName name) (WorkflowId wid) gen = - Map.fromList <$> runTransaction (Tx.statement (wid, name, fromIntegral gen :: Int32) loadStepIndexStmt) + Map.fromList <$> runTransaction (Tx.statement (wid, name, fromIntegral gen :: Int32) loadStepIndexStmt) -{- | Point-lookup one recorded step result for a workflow instance and -generation, directly from the authoritative @keiro_workflow_steps@ index. -Used by the replay handler's @Await@ miss path as the safety net for a stale -in-memory map: the index is written in the same transaction as every journal -append, so it is complete even when the snapshot-seeded map is not. --} +-- | Point-lookup one recorded step result for a workflow instance and +-- generation, directly from the authoritative @keiro_workflow_steps@ index. +-- Used by the replay handler's @Await@ miss path as the safety net for a stale +-- in-memory map: the index is written in the same transaction as every journal +-- append, so it is complete even when the snapshot-seeded map is not. lookupStepResult :: (Store :> es) => WorkflowName -> WorkflowId -> Int -> Text -> Eff es (Maybe Value) lookupStepResult (WorkflowName name) (WorkflowId wid) gen key = - runTransaction (Tx.statement (wid, name, fromIntegral gen :: Int32, key) lookupStepResultStmt) + runTransaction (Tx.statement (wid, name, fromIntegral gen :: Int32, key) lookupStepResultStmt) -{- | Whether a workflow instance already has an index row for the given step -name. Used to make journal re-appends idempotent without relying on the event -store's duplicate-id rejection. --} +-- | Whether a workflow instance already has an index row for the given step +-- name. Used to make journal re-appends idempotent without relying on the event +-- store's duplicate-id rejection. stepExists :: (Store :> es) => WorkflowName -> WorkflowId -> Int -> Text -> Eff es Bool stepExists (WorkflowName name) (WorkflowId wid) gen key = - runTransaction (Tx.statement (wid, name, fromIntegral gen :: Int32, key) stepExistsStmt) + runTransaction (Tx.statement (wid, name, fromIntegral gen :: Int32, key) stepExistsStmt) -{- | The current (highest) generation recorded for a logical workflow, or 0 if -it has no step rows yet (EP-48). Index-supported by the -@(workflow_id, workflow_name, generation)@ lookup index. A workflow that never -rotates stays at generation 0 and behaves byte-for-byte as it did before EP-48. -A rotation commits the next generation's seed step under generation @g+1@ in -the same logical-id key space, so @MAX(generation)@ is unambiguously the -current generation. --} +-- | The current (highest) generation recorded for a logical workflow, or 0 if +-- it has no step rows yet (EP-48). Index-supported by the +-- @(workflow_id, workflow_name, generation)@ lookup index. A workflow that never +-- rotates stays at generation 0 and behaves byte-for-byte as it did before EP-48. +-- A rotation commits the next generation's seed step under generation @g+1@ in +-- the same logical-id key space, so @MAX(generation)@ is unambiguously the +-- current generation. currentGeneration :: (Store :> es) => WorkflowName -> WorkflowId -> Eff es Int currentGeneration (WorkflowName name) (WorkflowId wid) = - fromIntegral <$> runTransaction (Tx.statement (wid, name) currentGenerationStmt) + fromIntegral <$> runTransaction (Tx.statement (wid, name) currentGenerationStmt) -{- | Return the @(workflow_id, workflow_name)@ of every non-terminal workflow -instance. Terminal statuses are @completed@, @cancelled@, and @failed@, matching -'Keiro.Workflow.Instance.WorkflowStatus'. The explicit time parameter is -reserved for wake-time filtering; today it keeps the call shape stable for that -addition. --} +-- | Return the @(workflow_id, workflow_name)@ of every non-terminal workflow +-- instance. Terminal statuses are @completed@, @cancelled@, and @failed@, matching +-- 'Keiro.Workflow.Instance.WorkflowStatus'. The explicit time parameter is +-- reserved for wake-time filtering; today it keeps the call shape stable for that +-- addition. findUnfinishedWorkflowIds :: (Store :> es) => UTCTime -> Eff es [(Text, Text)] findUnfinishedWorkflowIds now = - runTransaction (Tx.statement now findUnfinishedWorkflowIdsStmt) + runTransaction (Tx.statement now findUnfinishedWorkflowIdsStmt) recordStepStmt :: Statement (Text, Text, Int32, Text, Value, UTCTime) () recordStepStmt = - preparable - """ - INSERT INTO keiro.keiro_workflow_steps - (workflow_id, workflow_name, generation, step_name, result, recorded_at) - VALUES ($1, $2, $3, $4, $5, $6) - ON CONFLICT (workflow_id, workflow_name, generation, step_name) DO NOTHING - """ - ( contrazip6 - (E.param (E.nonNullable E.text)) - (E.param (E.nonNullable E.text)) - (E.param (E.nonNullable E.int4)) - (E.param (E.nonNullable E.text)) - (E.param (E.nonNullable E.jsonb)) - (E.param (E.nonNullable E.timestamptz)) - ) - D.noResult + preparable + """ + INSERT INTO keiro.keiro_workflow_steps + (workflow_id, workflow_name, generation, step_name, result, recorded_at) + VALUES ($1, $2, $3, $4, $5, $6) + ON CONFLICT (workflow_id, workflow_name, generation, step_name) DO NOTHING + """ + ( contrazip6 + (E.param (E.nonNullable E.text)) + (E.param (E.nonNullable E.text)) + (E.param (E.nonNullable E.int4)) + (E.param (E.nonNullable E.text)) + (E.param (E.nonNullable E.jsonb)) + (E.param (E.nonNullable E.timestamptz)) + ) + D.noResult lookupStepResultStmt :: Statement (Text, Text, Int32, Text) (Maybe Value) lookupStepResultStmt = - preparable - """ - SELECT result - FROM keiro.keiro_workflow_steps - WHERE workflow_id = $1 AND workflow_name = $2 AND generation = $3 AND step_name = $4 - """ - ( contrazip4 - (E.param (E.nonNullable E.text)) - (E.param (E.nonNullable E.text)) - (E.param (E.nonNullable E.int4)) - (E.param (E.nonNullable E.text)) - ) - (D.rowMaybe (D.column (D.nonNullable D.jsonb))) + preparable + """ + SELECT result + FROM keiro.keiro_workflow_steps + WHERE workflow_id = $1 AND workflow_name = $2 AND generation = $3 AND step_name = $4 + """ + ( contrazip4 + (E.param (E.nonNullable E.text)) + (E.param (E.nonNullable E.text)) + (E.param (E.nonNullable E.int4)) + (E.param (E.nonNullable E.text)) + ) + (D.rowMaybe (D.column (D.nonNullable D.jsonb))) lockWorkflowStepStmt :: Statement Text Int32 lockWorkflowStepStmt = - preparable - """ - SELECT 1::int4 FROM pg_advisory_xact_lock(hashtextextended($1, 0)) - """ - (E.param (E.nonNullable E.text)) - (D.singleRow (D.column (D.nonNullable D.int4))) + preparable + """ + SELECT 1::int4 FROM pg_advisory_xact_lock(hashtextextended($1, 0)) + """ + (E.param (E.nonNullable E.text)) + (D.singleRow (D.column (D.nonNullable D.int4))) deleteStepRowStmt :: Statement (Text, Text, Int32, Text) () deleteStepRowStmt = - preparable - """ - DELETE FROM keiro.keiro_workflow_steps - WHERE workflow_id = $1 - AND workflow_name = $2 - AND generation = $3 - AND step_name = $4 - """ - ( contrazip4 - (E.param (E.nonNullable E.text)) - (E.param (E.nonNullable E.text)) - (E.param (E.nonNullable E.int4)) - (E.param (E.nonNullable E.text)) - ) - D.noResult + preparable + """ + DELETE FROM keiro.keiro_workflow_steps + WHERE workflow_id = $1 + AND workflow_name = $2 + AND generation = $3 + AND step_name = $4 + """ + ( contrazip4 + (E.param (E.nonNullable E.text)) + (E.param (E.nonNullable E.text)) + (E.param (E.nonNullable E.int4)) + (E.param (E.nonNullable E.text)) + ) + D.noResult loadStepIndexStmt :: Statement (Text, Text, Int32) [(Text, Value)] loadStepIndexStmt = - preparable - """ - SELECT step_name, result - FROM keiro.keiro_workflow_steps - WHERE workflow_id = $1 AND workflow_name = $2 AND generation = $3 - """ - ( contrazip3 - (E.param (E.nonNullable E.text)) - (E.param (E.nonNullable E.text)) - (E.param (E.nonNullable E.int4)) - ) - (D.rowList ((,) <$> D.column (D.nonNullable D.text) <*> D.column (D.nonNullable D.jsonb))) + preparable + """ + SELECT step_name, result + FROM keiro.keiro_workflow_steps + WHERE workflow_id = $1 AND workflow_name = $2 AND generation = $3 + """ + ( contrazip3 + (E.param (E.nonNullable E.text)) + (E.param (E.nonNullable E.text)) + (E.param (E.nonNullable E.int4)) + ) + (D.rowList ((,) <$> D.column (D.nonNullable D.text) <*> D.column (D.nonNullable D.jsonb))) stepExistsStmt :: Statement (Text, Text, Int32, Text) Bool stepExistsStmt = - preparable - """ - SELECT EXISTS ( - SELECT 1 FROM keiro.keiro_workflow_steps - WHERE workflow_id = $1 AND workflow_name = $2 AND generation = $3 AND step_name = $4 - ) - """ - ( contrazip4 - (E.param (E.nonNullable E.text)) - (E.param (E.nonNullable E.text)) - (E.param (E.nonNullable E.int4)) - (E.param (E.nonNullable E.text)) - ) - (D.singleRow (D.column (D.nonNullable D.bool))) + preparable + """ + SELECT EXISTS ( + SELECT 1 FROM keiro.keiro_workflow_steps + WHERE workflow_id = $1 AND workflow_name = $2 AND generation = $3 AND step_name = $4 + ) + """ + ( contrazip4 + (E.param (E.nonNullable E.text)) + (E.param (E.nonNullable E.text)) + (E.param (E.nonNullable E.int4)) + (E.param (E.nonNullable E.text)) + ) + (D.singleRow (D.column (D.nonNullable D.bool))) -- The current generation is MAX(generation) for the logical id+name, or 0 when -- the workflow has no rows. Index-supported by keiro_workflow_steps_workflow_idx. currentGenerationStmt :: Statement (Text, Text) Int32 currentGenerationStmt = - preparable - """ - SELECT COALESCE(MAX(generation), 0)::int4 - FROM keiro.keiro_workflow_steps - WHERE workflow_id = $1 AND workflow_name = $2 - """ - ( contrazip2 - (E.param (E.nonNullable E.text)) - (E.param (E.nonNullable E.text)) - ) - (D.singleRow (D.column (D.nonNullable D.int4))) + preparable + """ + SELECT COALESCE(MAX(generation), 0)::int4 + FROM keiro.keiro_workflow_steps + WHERE workflow_id = $1 AND workflow_name = $2 + """ + ( contrazip2 + (E.param (E.nonNullable E.text)) + (E.param (E.nonNullable E.text)) + ) + (D.singleRow (D.column (D.nonNullable D.int4))) -- The terminal-status literals must match 'Keiro.Workflow.Instance.statusToText' -- for completed, cancelled, and failed. The timestamp parameter makes @@ -268,44 +259,44 @@ -- until their timer is due. findUnfinishedWorkflowIdsStmt :: Statement UTCTime [(Text, Text)] findUnfinishedWorkflowIdsStmt = - preparable - """ - SELECT workflow_id, workflow_name - FROM keiro.keiro_workflows - WHERE status NOT IN ('completed', 'cancelled', 'failed') - AND (wake_after IS NULL OR wake_after <= $1) - ORDER BY workflow_name, workflow_id - """ - (E.param (E.nonNullable E.timestamptz)) - (D.rowList ((,) <$> D.column (D.nonNullable D.text) <*> D.column (D.nonNullable D.text))) + preparable + """ + SELECT workflow_id, workflow_name + FROM keiro.keiro_workflows + WHERE status NOT IN ('completed', 'cancelled', 'failed') + AND (wake_after IS NULL OR wake_after <= $1) + ORDER BY workflow_name, workflow_id + """ + (E.param (E.nonNullable E.timestamptz)) + (D.rowList ((,) <$> D.column (D.nonNullable D.text) <*> D.column (D.nonNullable D.text))) setWorkflowWakeAfterStmt :: Statement (Text, Text, UTCTime) () setWorkflowWakeAfterStmt = - preparable - """ - UPDATE keiro.keiro_workflows - SET wake_after = $3, - updated_at = now() - WHERE workflow_id = $1 AND workflow_name = $2 - """ - ( contrazip3 - (E.param (E.nonNullable E.text)) - (E.param (E.nonNullable E.text)) - (E.param (E.nonNullable E.timestamptz)) - ) - D.noResult + preparable + """ + UPDATE keiro.keiro_workflows + SET wake_after = $3, + updated_at = now() + WHERE workflow_id = $1 AND workflow_name = $2 + """ + ( contrazip3 + (E.param (E.nonNullable E.text)) + (E.param (E.nonNullable E.text)) + (E.param (E.nonNullable E.timestamptz)) + ) + D.noResult clearWorkflowWakeAfterStmt :: Statement (Text, Text) () clearWorkflowWakeAfterStmt = - preparable - """ - UPDATE keiro.keiro_workflows - SET wake_after = NULL, - updated_at = now() - WHERE workflow_id = $1 AND workflow_name = $2 - """ - ( contrazip2 - (E.param (E.nonNullable E.text)) - (E.param (E.nonNullable E.text)) - ) - D.noResult + preparable + """ + UPDATE keiro.keiro_workflows + SET wake_after = NULL, + updated_at = now() + WHERE workflow_id = $1 AND workflow_name = $2 + """ + ( contrazip2 + (E.param (E.nonNullable E.text)) + (E.param (E.nonNullable E.text)) + ) + D.noResult diff --git a/src/Keiro/Workflow/Sleep.hs b/src/Keiro/Workflow/Sleep.hs --- a/src/Keiro/Workflow/Sleep.hs +++ b/src/Keiro/Workflow/Sleep.hs @@ -1,81 +1,80 @@ -{- | Durable @sleep@ for workflows, backed by the existing @keiro_timers@ table. - -== What this gives you - -A workflow author can insert a durable pause between steps: - -@ -demo :: ('Workflow' ':>' es, 'Store' ':>' es, IOE ':>' es) => Eff es (Int, Int) -demo = do - a <- 'step' (StepName \"a\") (liftIO incr) -- side effect #1 - 'sleepNamed' (StepName \"cool\") 300 -- durable wait, survives a restart - b <- 'step' (StepName \"b\") (liftIO incr) -- side effect #2 - pure (a, b) -@ - -On the __first__ run, @demo@ executes @a@, journals it, arms a Postgres timer -for the sleep, and __suspends__ — 'Keiro.Workflow.runWorkflow' returns -'Suspended' and the journal @wf:demo-\@ 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:\\",\"gen\":0}@ - in its @payload@ (see 'sleepTimerPayload' / 'parseSleepPayload'). This is how - a single timer worker distinguishes workflow sleeps from ordinary - process-manager timers, routes each correctly, and pins a fire to the - generation that armed it. Legacy payloads without @gen@ remain supported. - -* __Deterministic timer id.__ The timer id is a v5 UUID over - @(\"keiro\":\"workflow-sleep\":name:id:generation:sleepStepName)@ for - generation 1 and later, while generation 0 keeps the legacy - @(\"keiro\":\"workflow-sleep\":name:id:sleepStepName)@ shape. The workflow - sleep arm uses 'Keiro.Timer.scheduleTimerOnceTx', so the first arm's - @fire_at@ wins and every resume that re-enters the not-yet-resolved sleep - leaves the row untouched. The sleep duration is measured from the first arm, - not from the latest resume pass. - -* __No @keiro_timers@ schema change.__ Routing is entirely a function of the - caller-supplied fire action and the JSON payload; this module owns no - migration. - -* __A worker must drain the timers.__ A sleep only ever fires if some timer - worker runs 'workflowSleepFireAction' (via 'runWorkflowTimerWorker', or by - passing 'workflowSleepFireAction' directly to 'Keiro.Timer.runTimerWorker'). - A sleep whose timer is never drained — or one whose timer an operator - 'Keiro.Timer.cancelTimer's — stays suspended forever until an operator - intervenes. Workflow sleeps otherwise inherit the timer subsystem's recovery - surface ('Keiro.Timer.findStuckTimers' / 'Keiro.Timer.requeueStuckTimer' / - 'Keiro.Timer.deadLetterTimer') for free. --} -module Keiro.Workflow.Sleep ( - -- * Authoring surface +-- | Durable @sleep@ for workflows, backed by the existing @keiro_timers@ table. +-- +-- == What this gives you +-- +-- A workflow author can insert a durable pause between steps: +-- +-- @ +-- demo :: ('Workflow' ':>' es, 'Store' ':>' es, IOE ':>' es) => Eff es (Int, Int) +-- demo = do +-- a <- 'step' (StepName \"a\") (liftIO incr) -- side effect #1 +-- 'sleepNamed' (StepName \"cool\") 300 -- durable wait, survives a restart +-- b <- 'step' (StepName \"b\") (liftIO incr) -- side effect #2 +-- pure (a, b) +-- @ +-- +-- On the __first__ run, @demo@ executes @a@, journals it, arms a Postgres timer +-- for the sleep, and __suspends__ — 'Keiro.Workflow.runWorkflow' returns +-- 'Suspended' and the journal @wf:demo-\@ 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:\\",\"gen\":0}@ +-- in its @payload@ (see 'sleepTimerPayload' / 'parseSleepPayload'). This is how +-- a single timer worker distinguishes workflow sleeps from ordinary +-- process-manager timers, routes each correctly, and pins a fire to the +-- generation that armed it. Legacy payloads without @gen@ remain supported. +-- +-- * __Deterministic timer id.__ The timer id is a v5 UUID over +-- @(\"keiro\":\"workflow-sleep\":name:id:generation:sleepStepName)@ for +-- generation 1 and later, while generation 0 keeps the legacy +-- @(\"keiro\":\"workflow-sleep\":name:id:sleepStepName)@ shape. The workflow +-- sleep arm uses 'Keiro.Timer.scheduleTimerOnceTx', so the first arm's +-- @fire_at@ wins and every resume that re-enters the not-yet-resolved sleep +-- leaves the row untouched. The sleep duration is measured from the first arm, +-- not from the latest resume pass. +-- +-- * __No @keiro_timers@ schema change.__ Routing is entirely a function of the +-- caller-supplied fire action and the JSON payload; this module owns no +-- migration. +-- +-- * __A worker must drain the timers.__ A sleep only ever fires if some timer +-- worker runs 'workflowSleepFireAction' (via 'runWorkflowTimerWorker', or by +-- passing 'workflowSleepFireAction' directly to 'Keiro.Timer.runTimerWorker'). +-- A sleep whose timer is never drained — or one whose timer an operator +-- 'Keiro.Timer.cancelTimer's — stays suspended forever until an operator +-- intervenes. Workflow sleeps otherwise inherit the timer subsystem's recovery +-- surface ('Keiro.Timer.findStuckTimers' / 'Keiro.Timer.requeueStuckTimer' / +-- 'Keiro.Timer.deadLetterTimer') for free. +module Keiro.Workflow.Sleep + ( -- * Authoring surface sleepNamed, sleep, @@ -90,7 +89,7 @@ parseSleepPayload, matchSleepTimerGeneration, workflowSleepKind, -) + ) where import Data.Aeson (Value (..), object) @@ -104,16 +103,16 @@ import Effectful.Exception (throwIO) import Keiro.Prelude import Keiro.Telemetry (KeiroMetrics) -import Keiro.Timer ( - TimerId (..), +import Keiro.Timer + ( TimerId (..), TimerRequest (..), TimerRow, cancelTimer, runTimerWorker, scheduleTimerOnceTx, - ) -import Keiro.Workflow ( - JournalAppendOutcome (..), + ) +import Keiro.Workflow + ( JournalAppendOutcome (..), StepName (..), Workflow, WorkflowError (..), @@ -130,7 +129,7 @@ prepareJournalAppend, setWorkflowWakeAfterTx, sleepStepPrefix, - ) + ) import Keiro.Workflow.Instance qualified as Instance import Kiroku.Store.Effect (Store) import Kiroku.Store.Transaction (runTransaction) @@ -140,106 +139,100 @@ -- Discriminator and payload -- --------------------------------------------------------------------------- -{- | The payload @"kind"@ tag that marks a 'keiro_timers' row as a workflow -sleep, distinguishing it from an ordinary process-manager timer so a single -timer worker can route each correctly. --} +-- | The payload @"kind"@ tag that marks a 'keiro_timers' row as a workflow +-- sleep, distinguishing it from an ordinary process-manager timer so a single +-- timer worker can route each correctly. workflowSleepKind :: Text workflowSleepKind = "keiro.workflow.sleep" -{- | Build the JSON payload carried on a workflow-sleep timer row. The first -argument is the generation that armed the timer; the second is the full -@"sleep:\"@ journal step name the firing will record. --} +-- | Build the JSON payload carried on a workflow-sleep timer row. The first +-- argument is the generation that armed the timer; the second is the full +-- @"sleep:\"@ journal step name the firing will record. sleepTimerPayload :: Int -> Text -> Value sleepTimerPayload gen fullStep = - object - [ "kind" Aeson..= workflowSleepKind - , "step" Aeson..= fullStep - , "gen" Aeson..= gen - ] + object + [ "kind" Aeson..= workflowSleepKind, + "step" Aeson..= fullStep, + "gen" Aeson..= gen + ] -{- | Recognise and extract a workflow-sleep payload. The result contains the -full step name and the generation when the payload records one. 'Nothing' in -the generation slot denotes a legacy workflow-sleep payload written before -generation pinning; an overall 'Nothing' denotes any other timer (for example, -a process manager's). --} +-- | Recognise and extract a workflow-sleep payload. The result contains the +-- full step name and the generation when the payload records one. 'Nothing' in +-- the generation slot denotes a legacy workflow-sleep payload written before +-- generation pinning; an overall 'Nothing' denotes any other timer (for example, +-- a process manager's). parseSleepPayload :: Value -> Maybe (Text, Maybe Int) parseSleepPayload = \case - Object o - | KeyMap.lookup "kind" o == Just (String workflowSleepKind) -> - case KeyMap.lookup "step" o of - Just (String s) -> - case KeyMap.lookup "gen" o of - Nothing -> Just (s, Nothing) - Just value -> - case Aeson.fromJSON value of - Aeson.Success gen -> Just (s, Just gen) - Aeson.Error{} -> Nothing - _ -> Nothing - _ -> Nothing + Object o + | KeyMap.lookup "kind" o == Just (String workflowSleepKind) -> + case KeyMap.lookup "step" o of + Just (String s) -> + case KeyMap.lookup "gen" o of + Nothing -> Just (s, Nothing) + Just value -> + case Aeson.fromJSON value of + Aeson.Success gen -> Just (s, Just gen) + Aeson.Error {} -> Nothing + _ -> Nothing + _ -> Nothing -- --------------------------------------------------------------------------- -- Deterministic ids and step names -- --------------------------------------------------------------------------- -{- | The deterministic timer id for a sleep. Generation 0 keeps the legacy v5 -UUID over @(\"keiro\":\"workflow-sleep\":name:id:fullStep)@ so in-flight -pre-change timers remain signalable. Generations 1 and later include the -generation component so a sleep after 'Keiro.Workflow.continueAsNew' never -collides with a prior generation's terminal timer row. --} +-- | The deterministic timer id for a sleep. Generation 0 keeps the legacy v5 +-- UUID over @(\"keiro\":\"workflow-sleep\":name:id:fullStep)@ so in-flight +-- pre-change timers remain signalable. Generations 1 and later include the +-- generation component so a sleep after 'Keiro.Workflow.continueAsNew' never +-- collides with a prior generation's terminal timer row. sleepTimerId :: WorkflowName -> WorkflowId -> Int -> Text -> TimerId sleepTimerId name wid gen fullStep = - TimerId $ - UUID.V5.generateNamed UUID.V5.namespaceURL $ - fmap (fromIntegral . fromEnum) $ - Text.unpack $ - Text.intercalate - ":" - components + TimerId $ + UUID.V5.generateNamed UUID.V5.namespaceURL $ + fmap (fromIntegral . fromEnum) $ + Text.unpack $ + Text.intercalate + ":" + components where components - | gen <= 0 = - [ "keiro" - , "workflow-sleep" - , unWorkflowName name - , unWorkflowId wid - , fullStep - ] - | otherwise = - [ "keiro" - , "workflow-sleep" - , unWorkflowName name - , unWorkflowId wid - , Text.pack (show gen) - , fullStep - ] + | gen <= 0 = + [ "keiro", + "workflow-sleep", + unWorkflowName name, + unWorkflowId wid, + fullStep + ] + | otherwise = + [ "keiro", + "workflow-sleep", + unWorkflowName name, + unWorkflowId wid, + Text.pack (show gen), + fullStep + ] -{- | Recover the generation represented by a deterministic workflow-sleep -timer id. Candidate generations from @currentGen@ down to zero are tested -against 'sleepTimerId'; this lets a new worker pin legacy payloads that do not -carry an explicit generation. Returns 'Nothing' only for an operator-crafted -or otherwise non-matching timer id. --} +-- | Recover the generation represented by a deterministic workflow-sleep +-- timer id. Candidate generations from @currentGen@ down to zero are tested +-- against 'sleepTimerId'; this lets a new worker pin legacy payloads that do not +-- carry an explicit generation. Returns 'Nothing' only for an operator-crafted +-- or otherwise non-matching timer id. matchSleepTimerGeneration :: - WorkflowName -> - WorkflowId -> - Int -> - Text -> - TimerId -> - Maybe Int + WorkflowName -> + WorkflowId -> + Int -> + Text -> + TimerId -> + Maybe Int matchSleepTimerGeneration name wid currentGen fullStep timerId = - find - (\gen -> sleepTimerId name wid gen fullStep == timerId) - (reverse [0 .. max 0 currentGen]) + find + (\gen -> sleepTimerId name wid gen fullStep == timerId) + (reverse [0 .. max 0 currentGen]) -{- | The durable journal step name for a sleep: the user's suffix prefixed with -'sleepStepPrefix'. @'sleepStepName' (StepName \"cool\") == \"sleep:cool\"@. The -prefix keeps the journal self-describing — an operator scanning it sees -@sleep:@ and knows the entry is a durable wait, not an ordinary step. --} +-- | The durable journal step name for a sleep: the user's suffix prefixed with +-- 'sleepStepPrefix'. @'sleepStepName' (StepName \"cool\") == \"sleep:cool\"@. The +-- prefix keeps the journal self-describing — an operator scanning it sees +-- @sleep:@ and knows the entry is a durable wait, not an ordinary step. sleepStepName :: StepName -> Text sleepStepName (StepName suffix) = sleepStepPrefix <> suffix @@ -247,139 +240,134 @@ -- Authoring surface -- --------------------------------------------------------------------------- -{- | 'awaitStep' specialised to a 'Value' result. The recorded sleep completion -carries JSON @null@; 'Value''s 'FromJSON' is the identity, so any recorded -result decodes, which decouples the sleep from a @FromJSON ()@ instance. --} +-- | 'awaitStep' specialised to a 'Value' result. The recorded sleep completion +-- carries JSON @null@; 'Value''s 'FromJSON' is the identity, so any recorded +-- result decodes, which decouples the sleep from a @FromJSON ()@ instance. awaitValue :: (Workflow :> es) => StepName -> Eff es () -> Eff es Value awaitValue = awaitStep -{- | Durably pause the workflow for @delta@ under the stable name @userStep@. -On the first encounter this arms a deterministic 'keiro_timers' row and -suspends the run; the suspension resolves when a timer worker fires the row -(see 'workflowSleepFireAction') and journals the sleep's completion, after which -a later run replays past the sleep without re-arming. - -The arming action is idempotent (a resumed workflow re-runs it until the sleep -resolves): it inserts with a deterministic 'sleepTimerId' only when the row is -absent, so the first @fire_at@ persists across every resume pass. --} +-- | Durably pause the workflow for @delta@ under the stable name @userStep@. +-- On the first encounter this arms a deterministic 'keiro_timers' row and +-- suspends the run; the suspension resolves when a timer worker fires the row +-- (see 'workflowSleepFireAction') and journals the sleep's completion, after which +-- a later run replays past the sleep without re-arming. +-- +-- The arming action is idempotent (a resumed workflow re-runs it until the sleep +-- resolves): it inserts with a deterministic 'sleepTimerId' only when the row is +-- absent, so the first @fire_at@ persists across every resume pass. sleepNamed :: - (Workflow :> es, Store :> es, IOE :> es) => - StepName -> - NominalDiffTime -> - Eff es () + (Workflow :> es, Store :> es, IOE :> es) => + StepName -> + NominalDiffTime -> + Eff es () sleepNamed userStep delta = do - (name, wid) <- currentWorkflow - gen <- currentRunGeneration - let full = sleepStepName userStep - armedStep = StepName full - void . awaitValue armedStep $ do - now <- liftIO getCurrentTime - let request = - TimerRequest - { timerId = sleepTimerId name wid gen full - , processManagerName = unWorkflowName name - , correlationId = unWorkflowId wid - , fireAt = addUTCTime delta now - , payload = sleepTimerPayload gen full - } - -- Only the arm that created the timer writes the wake hint. Replays - -- leave both fire_at and wake_after untouched, so re-entering a due or - -- already-fired sleep cannot postpone discovery. Firing clears the - -- hint in the same transaction as its journal append. - runTransaction $ do - inserted <- scheduleTimerOnceTx request - when inserted (setWorkflowWakeAfterTx name wid (request ^. #fireAt)) + (name, wid) <- currentWorkflow + gen <- currentRunGeneration + let full = sleepStepName userStep + armedStep = StepName full + void . awaitValue armedStep $ do + now <- liftIO getCurrentTime + let request = + TimerRequest + { timerId = sleepTimerId name wid gen full, + processManagerName = unWorkflowName name, + correlationId = unWorkflowId wid, + fireAt = addUTCTime delta now, + payload = sleepTimerPayload gen full + } + -- Only the arm that created the timer writes the wake hint. Replays + -- leave both fire_at and wake_after untouched, so re-entering a due or + -- already-fired sleep cannot postpone discovery. Firing clears the + -- hint in the same transaction as its journal append. + runTransaction $ do + inserted <- scheduleTimerOnceTx request + when inserted (setWorkflowWakeAfterTx name wid (request ^. #fireAt)) -{- | Durably pause the workflow for @delta@ under an ordinal name (the @N@th -sleep in a run becomes @sleep:N@). Convenient but its determinism is -conditional — see the module header. Prefer 'sleepNamed' for anything that must -survive a code change mid-flight. --} +-- | Durably pause the workflow for @delta@ under an ordinal name (the @N@th +-- sleep in a run becomes @sleep:N@). Convenient but its determinism is +-- conditional — see the module header. Prefer 'sleepNamed' for anything that must +-- survive a code change mid-flight. sleep :: (Workflow :> es, Store :> es, IOE :> es) => NominalDiffTime -> Eff es () sleep delta = do - n <- freshOrdinal "sleep" - sleepNamed (StepName (Text.pack (show n))) delta + n <- freshOrdinal "sleep" + sleepNamed (StepName (Text.pack (show n))) delta -- --------------------------------------------------------------------------- -- Firing and worker wiring -- --------------------------------------------------------------------------- -{- | The fire action for workflow-sleep timers. For a 'TimerRow' whose payload -is a workflow-sleep discriminator, reconstruct the workflow identity from the -row's @processManagerName@ (= workflow name) and @correlationId@ (= workflow -id), resolve the generation that armed the timer, append a @StepRecorded@ -completion (@result = null@) to that generation's journal, and return the -deterministic 'EventId' so the worker marks the timer @Fired@. Returns -'Nothing' for a row whose payload is __not__ a workflow sleep, or for a sleep -owned by a terminal workflow (whose timer is cancelled), so a mixed worker can -delegate that row to its process-manager fire action. - -Idempotent: 'prepareJournalAppend' pre-checks the generation-scoped step and -the event id is deterministic, so at-least-once timer firing yields -exactly-once journaling even after the workflow has rotated. --} +-- | The fire action for workflow-sleep timers. For a 'TimerRow' whose payload +-- is a workflow-sleep discriminator, reconstruct the workflow identity from the +-- row's @processManagerName@ (= workflow name) and @correlationId@ (= workflow +-- id), resolve the generation that armed the timer, append a @StepRecorded@ +-- completion (@result = null@) to that generation's journal, and return the +-- deterministic 'EventId' so the worker marks the timer @Fired@. Returns +-- 'Nothing' for a row whose payload is __not__ a workflow sleep, or for a sleep +-- owned by a terminal workflow (whose timer is cancelled), so a mixed worker can +-- delegate that row to its process-manager fire action. +-- +-- Idempotent: 'prepareJournalAppend' pre-checks the generation-scoped step and +-- the event id is deterministic, so at-least-once timer firing yields +-- exactly-once journaling even after the workflow has rotated. workflowSleepFireAction :: - (Store :> es, IOE :> es) => TimerRow -> Eff es (Maybe EventId) + (Store :> es, IOE :> es) => TimerRow -> Eff es (Maybe EventId) workflowSleepFireAction row = - case parseSleepPayload (row ^. #payload) of - Nothing -> pure Nothing - Just (full, payloadGen) -> do - let name = WorkflowName (row ^. #processManagerName) - wid = WorkflowId (row ^. #correlationId) - Instance.lookupInstance name wid >>= \case - Just instanceRow - | instanceRow ^. #status - `elem` [Instance.WfCompleted, Instance.WfCancelled, Instance.WfFailed] -> do - void (cancelTimer (row ^. #timerId)) - pure Nothing - _ -> do - targetGen <- - case payloadGen of - Just gen -> pure gen - Nothing -> do - currentGen <- currentGeneration name wid - pure $ - fromMaybe - currentGen - (matchSleepTimerGeneration name wid currentGen full (row ^. #timerId)) - now <- liftIO getCurrentTime - appendTx <- - prepareJournalAppend - name - wid - targetGen - (StepRecorded{stepName = full, result = Null, recordedAt = now}) - runTransaction (appendTx <* clearWorkflowWakeAfterTx name wid) >>= \case - JournalAppended{} -> - pure (Just (deterministicJournalId name wid targetGen full)) - JournalAlreadyPresent{} -> - pure (Just (deterministicJournalId name wid targetGen full)) - JournalAppendConflict err -> - throwIO (WorkflowJournalAppendError (Text.pack (show err))) - -{- | A timer worker pass that handles __both__ workflow-sleep timers and -ordinary process-manager timers. For each claimed timer: if its payload is a -workflow sleep, wake the workflow; otherwise delegate to the supplied -process-manager fire action. + case parseSleepPayload (row ^. #payload) of + Nothing -> pure Nothing + Just (full, payloadGen) -> do + let name = WorkflowName (row ^. #processManagerName) + wid = WorkflowId (row ^. #correlationId) + Instance.lookupInstance name wid >>= \case + Just instanceRow + | instanceRow ^. #status + `elem` [Instance.WfCompleted, Instance.WfCancelled, Instance.WfFailed] -> do + void (cancelTimer (row ^. #timerId)) + pure Nothing + _ -> do + targetGen <- + case payloadGen of + Just gen -> pure gen + Nothing -> do + currentGen <- currentGeneration name wid + pure $ + fromMaybe + currentGen + (matchSleepTimerGeneration name wid currentGen full (row ^. #timerId)) + now <- liftIO getCurrentTime + appendTx <- + prepareJournalAppend + name + wid + targetGen + (StepRecorded {stepName = full, result = Null, recordedAt = now}) + runTransaction (appendTx <* clearWorkflowWakeAfterTx name wid) >>= \case + JournalAppended {} -> + pure (Just (deterministicJournalId name wid targetGen full)) + JournalAlreadyPresent {} -> + pure (Just (deterministicJournalId name wid targetGen full)) + JournalAppendConflict err -> + throwIO (WorkflowJournalAppendError (Text.pack (show err))) -A deployment that runs only workflows can pass @\\_ -> pure Nothing@ as the -fallback (or use 'workflowSleepFireAction' directly with -'Keiro.Timer.runTimerWorker'). A deployment that mixes process-manager timers -and workflow sleeps passes its existing PM fire action so one worker drains -both kinds. --} +-- | A timer worker pass that handles __both__ workflow-sleep timers and +-- ordinary process-manager timers. For each claimed timer: if its payload is a +-- workflow sleep, wake the workflow; otherwise delegate to the supplied +-- process-manager fire action. +-- +-- A deployment that runs only workflows can pass @\\_ -> pure Nothing@ as the +-- fallback (or use 'workflowSleepFireAction' directly with +-- 'Keiro.Timer.runTimerWorker'). A deployment that mixes process-manager timers +-- and workflow sleeps passes its existing PM fire action so one worker drains +-- both kinds. runWorkflowTimerWorker :: - (IOE :> es, Store :> es) => - Maybe KeiroMetrics -> - UTCTime -> - -- | Fallback fire action for non-sleep (process-manager) timers. - (TimerRow -> Eff es (Maybe EventId)) -> - Eff es (Maybe TimerRow) + (IOE :> es, Store :> es) => + Maybe KeiroMetrics -> + UTCTime -> + -- | Fallback fire action for non-sleep (process-manager) timers. + (TimerRow -> Eff es (Maybe EventId)) -> + Eff es (Maybe TimerRow) runWorkflowTimerWorker metrics now pmFire = - runTimerWorker metrics now $ \row -> do - handled <- workflowSleepFireAction row - case handled of - Just eid -> pure (Just eid) - Nothing -> pmFire row + runTimerWorker metrics now $ \row -> do + handled <- workflowSleepFireAction row + case handled of + Just eid -> pure (Just eid) + Nothing -> pmFire row diff --git a/src/Keiro/Workflow/Snapshot.hs b/src/Keiro/Workflow/Snapshot.hs --- a/src/Keiro/Workflow/Snapshot.hs +++ b/src/Keiro/Workflow/Snapshot.hs @@ -1,52 +1,51 @@ -{- | Workflow journal snapshots: the workflow-specific 'StateCodec' and the -read\/write helpers the runtime uses to skip a full version-0 replay. - -A durable workflow folds its journal stream into a 'WorkflowState' — a -@'Map' 'Text' 'Value'@ of step-name to encoded result. For a long-lived -workflow, re-reading the whole journal on every run and resume is ruinous. -This module supplies the EP-4 snapshot machinery the runtime reuses to -persist that folded map and, on the next run, seed from it and replay only -the tail. - -== Why a workflow-specific codec - -EP-4's 'Keiro.Snapshot.Codec.defaultStateCodec' derives its 'shapeHash' from -a /statically-known/ keiki register-file slot list -('Keiki.Shape.regFileShapeHash'). A workflow's step names are dynamic runtime -strings, so there is no static slot list. The accumulated state is instead a -self-describing JSON object, so it round-trips through Aeson trivially and its -/shape/ never varies with which steps ran. Hence the fixed sentinel -'workflowStateShapeHash'; per-step result-type evolution is each step's own -'Aeson.ToJSON'\/'Aeson.FromJSON' concern, surfaced at the @step@ decode in -"Keiro.Workflow", not here. - -== Advisory semantics - -A snapshot is an optimization, never a source of truth. 'loadWorkflowSnapshot' -returns 'Nothing' — meaning "replay from version 0" — when the stream has no -id yet, no matching snapshot, or an undecodable snapshot. So a stale or corrupt -snapshot degrades performance at worst, never correctness. - -Runtime snapshot writes are advisory too. After a workflow journal append has -committed, "Keiro.Workflow" swallows any snapshot-store failure and increments -@keiro.snapshot.write.failures@; the committed step, completion, or rotation -therefore still determines a successful run. This low-level module continues -to expose the store primitive, while the runtime owns that error handling. - -Snapshot writes store the full accumulated step map each time the selected -policy fires. With an every-n policy that means rewriting the complete map at -each boundary; the intended way to bound that cost for forever-running -workflows is 'Keiro.Workflow.continueAsNew', which starts a fresh generation -with a small carried seed. --} -module Keiro.Workflow.Snapshot ( - workflowStateCodec, +-- | Workflow journal snapshots: the workflow-specific 'StateCodec' and the +-- read\/write helpers the runtime uses to skip a full version-0 replay. +-- +-- A durable workflow folds its journal stream into a 'WorkflowState' — a +-- @'Map' 'Text' 'Value'@ of step-name to encoded result. For a long-lived +-- workflow, re-reading the whole journal on every run and resume is ruinous. +-- This module supplies the EP-4 snapshot machinery the runtime reuses to +-- persist that folded map and, on the next run, seed from it and replay only +-- the tail. +-- +-- == Why a workflow-specific codec +-- +-- EP-4's 'Keiro.Snapshot.Codec.defaultStateCodec' derives its 'shapeHash' from +-- a /statically-known/ keiki register-file slot list +-- ('Keiki.Shape.regFileShapeHash'). A workflow's step names are dynamic runtime +-- strings, so there is no static slot list. The accumulated state is instead a +-- self-describing JSON object, so it round-trips through Aeson trivially and its +-- /shape/ never varies with which steps ran. Hence the fixed sentinel +-- 'workflowStateShapeHash'; per-step result-type evolution is each step's own +-- 'Aeson.ToJSON'\/'Aeson.FromJSON' concern, surfaced at the @step@ decode in +-- "Keiro.Workflow", not here. +-- +-- == Advisory semantics +-- +-- A snapshot is an optimization, never a source of truth. 'loadWorkflowSnapshot' +-- returns 'Nothing' — meaning "replay from version 0" — when the stream has no +-- id yet, no matching snapshot, or an undecodable snapshot. So a stale or corrupt +-- snapshot degrades performance at worst, never correctness. +-- +-- Runtime snapshot writes are advisory too. After a workflow journal append has +-- committed, "Keiro.Workflow" swallows any snapshot-store failure and increments +-- @keiro.snapshot.write.failures@; the committed step, completion, or rotation +-- therefore still determines a successful run. This low-level module continues +-- to expose the store primitive, while the runtime owns that error handling. +-- +-- Snapshot writes store the full accumulated step map each time the selected +-- policy fires. With an every-n policy that means rewriting the complete map at +-- each boundary; the intended way to bound that cost for forever-running +-- workflows is 'Keiro.Workflow.continueAsNew', which starts a fresh generation +-- with a small carried seed. +module Keiro.Workflow.Snapshot + ( workflowStateCodec, workflowStateCodecVersion, workflowStateShapeHash, lookupWorkflowSnapshot, loadWorkflowSnapshot, writeWorkflowSnapshot, -) + ) where import Data.Aeson (Result (..)) @@ -61,77 +60,71 @@ import Kiroku.Store.Read (lookupStreamId) import Kiroku.Store.Types (StreamId, StreamName, StreamVersion) -{- | The codec version of the workflow snapshot envelope. Bumped only if the -map /envelope/ encoding itself changes (e.g. a switch from a bare JSON -object to a tagged container), never for a per-step result-type change. --} +-- | The codec version of the workflow snapshot envelope. Bumped only if the +-- map /envelope/ encoding itself changes (e.g. a switch from a bare JSON +-- object to a tagged container), never for a per-step result-type change. workflowStateCodecVersion :: Int workflowStateCodecVersion = 1 -{- | A FIXED sentinel shape hash. The accumulated state is always "a JSON -object of step-name strings to self-describing JSON values"; its /shape/ -never varies with which steps ran, so the shape hash is constant. Per-step -result-type evolution is the step's own 'Aeson.ToJSON'\/'Aeson.FromJSON' -concern, surfaced at the step decode in "Keiro.Workflow", not here. --} +-- | A FIXED sentinel shape hash. The accumulated state is always "a JSON +-- object of step-name strings to self-describing JSON values"; its /shape/ +-- never varies with which steps ran, so the shape hash is constant. Per-step +-- result-type evolution is the step's own 'Aeson.ToJSON'\/'Aeson.FromJSON' +-- concern, surfaced at the step decode in "Keiro.Workflow", not here. workflowStateShapeHash :: Text workflowStateShapeHash = "keiro.workflow.stepmap.v1" -{- | The workflow-specific 'StateCodec'. Encodes the accumulated -'WorkflowState' map straight to JSON and decodes it back, with a fixed -discriminant ('workflowStateCodecVersion', 'workflowStateShapeHash'). --} +-- | The workflow-specific 'StateCodec'. Encodes the accumulated +-- 'WorkflowState' map straight to JSON and decodes it back, with a fixed +-- discriminant ('workflowStateCodecVersion', 'workflowStateShapeHash'). workflowStateCodec :: StateCodec WorkflowState workflowStateCodec = - StateCodec - { stateCodecVersion = workflowStateCodecVersion - , shapeHash = workflowStateShapeHash - , stateShapeHash = workflowStateShapeHash - , encode = toJSON - , decode = \value -> case fromJSON value of - Success m -> Right m - Error msg -> Left (Text.pack msg) - } + StateCodec + { stateCodecVersion = workflowStateCodecVersion, + shapeHash = workflowStateShapeHash, + stateShapeHash = workflowStateShapeHash, + encode = toJSON, + decode = \value -> case fromJSON value of + Success m -> Right m + Error msg -> Left (Text.pack msg) + } -{- | Encode the accumulated map and upsert @keiro_snapshots@ for the journal -stream. Called from the @step@ miss-path (and the completion site) with the -'Kiroku.Store.Types.AppendResult'\'s @streamId@ and post-append @streamVersion@. -The underlying upsert keeps only the highest version per stream, so a re-fire -at an already-snapshotted version is a harmless no-op. --} +-- | Encode the accumulated map and upsert @keiro_snapshots@ for the journal +-- stream. Called from the @step@ miss-path (and the completion site) with the +-- 'Kiroku.Store.Types.AppendResult'\'s @streamId@ and post-append @streamVersion@. +-- The underlying upsert keeps only the highest version per stream, so a re-fire +-- at an already-snapshotted version is a harmless no-op. writeWorkflowSnapshot :: (Store :> es) => StreamId -> StreamVersion -> WorkflowState -> Eff es () writeWorkflowSnapshot streamId version state = - writeSnapshot streamId version workflowStateCodec state + writeSnapshot streamId version workflowStateCodec state -{- | Resolve the journal stream id, look up the latest matching snapshot row, -and decode it to a @('WorkflowState', 'StreamVersion')@ seed. Returns -'Nothing' — meaning "replay from 0" — when the stream has no id yet, no -matching snapshot, or an undecodable snapshot (advisory semantics). Mirrors -'Keiro.Snapshot.hydrateWithSnapshot''s miss-is-benign contract. --} +-- | Resolve the journal stream id, look up the latest matching snapshot row, +-- and decode it to a @('WorkflowState', 'StreamVersion')@ seed. Returns +-- 'Nothing' — meaning "replay from 0" — when the stream has no id yet, no +-- matching snapshot, or an undecodable snapshot (advisory semantics). Mirrors +-- 'Keiro.Snapshot.hydrateWithSnapshot''s miss-is-benign contract. loadWorkflowSnapshot :: (Store :> es) => StreamName -> Eff es (Maybe (WorkflowState, StreamVersion)) loadWorkflowSnapshot journalName = - lookupWorkflowSnapshot journalName <&> either (const Nothing) Just + lookupWorkflowSnapshot journalName <&> either (const Nothing) Just -{- | Resolve and decode a workflow snapshot while retaining the reason a -usable seed was unavailable. This is the observable counterpart to -'loadWorkflowSnapshot'. --} +-- | Resolve and decode a workflow snapshot while retaining the reason a +-- usable seed was unavailable. This is the observable counterpart to +-- 'loadWorkflowSnapshot'. lookupWorkflowSnapshot :: (Store :> es) => StreamName -> Eff es (Either SnapshotMissReason (WorkflowState, StreamVersion)) lookupWorkflowSnapshot journalName = do - mStreamId <- lookupStreamId journalName - case mStreamId of - Nothing -> pure (Left SnapshotNoStream) - Just streamId -> do - mRow <- - lookupSnapshot - streamId - workflowStateCodecVersion - workflowStateShapeHash - workflowStateShapeHash - pure $ case mRow of - Nothing -> Left SnapshotNotFound - Just row -> - case (workflowStateCodec ^. #decode) (row ^. #state) of - Left message -> Left (SnapshotDecodeFailed message) - Right state -> Right (state, row ^. #streamVersion) + mStreamId <- lookupStreamId journalName + case mStreamId of + Nothing -> pure (Left SnapshotNoStream) + Just streamId -> do + mRow <- + lookupSnapshot + streamId + workflowStateCodecVersion + workflowStateShapeHash + workflowStateShapeHash + pure $ case mRow of + Nothing -> Left SnapshotNotFound + Just row -> + case (workflowStateCodec ^. #decode) (row ^. #state) of + Left message -> Left (SnapshotDecodeFailed message) + Right state -> Right (state, row ^. #streamVersion) diff --git a/src/Keiro/Workflow/Types.hs b/src/Keiro/Workflow/Types.hs --- a/src/Keiro/Workflow/Types.hs +++ b/src/Keiro/Workflow/Types.hs @@ -1,25 +1,24 @@ {-# OPTIONS_GHC -Wno-partial-fields #-} -{- | Core types and the journal codec for the durable workflow runtime. - -A /durable workflow/ is an ordinary @effectful@ computation whose side -effects are recorded ("journaled") at named checkpoints so the computation -can be paused and resumed across crashes without re-running work that -already happened. The journal is a kiroku stream named -@wf:\-\@ ('workflowStreamName') holding one -'StepRecorded' event per executed step and a terminal 'WorkflowCompleted' -event. - -This module owns the contracts every sibling plan of the v2 MasterPlan -builds on: the identity newtypes ('WorkflowName', 'WorkflowId', -'StepName'), the journal event sum ('WorkflowJournalEvent') and its -'Codec' ('workflowJournalCodec'), the accumulated-state alias -('WorkflowState'), the run outcome ('WorkflowOutcome'), and the -reserved step-name conventions ('completedStepName' plus the -@sleep:@\/@awk:@\/@child:@ prefixes). --} -module Keiro.Workflow.Types ( - -- * Identity +-- | Core types and the journal codec for the durable workflow runtime. +-- +-- A /durable workflow/ is an ordinary @effectful@ computation whose side +-- effects are recorded ("journaled") at named checkpoints so the computation +-- can be paused and resumed across crashes without re-running work that +-- already happened. The journal is a kiroku stream named +-- @wf:\-\@ ('workflowStreamName') holding one +-- 'StepRecorded' event per executed step and a terminal 'WorkflowCompleted' +-- event. +-- +-- This module owns the contracts every sibling plan of the v2 MasterPlan +-- builds on: the identity newtypes ('WorkflowName', 'WorkflowId', +-- 'StepName'), the journal event sum ('WorkflowJournalEvent') and its +-- 'Codec' ('workflowJournalCodec'), the accumulated-state alias +-- ('WorkflowState'), the run outcome ('WorkflowOutcome'), and the +-- reserved step-name conventions ('completedStepName' plus the +-- @sleep:@\/@awk:@\/@child:@ prefixes). +module Keiro.Workflow.Types + ( -- * Identity WorkflowName (..), WorkflowId (..), WorkflowIdentityError (..), @@ -53,7 +52,7 @@ patchStepPrefix, patchSetStepName, patchStepName, -) + ) where import Data.Aeson qualified as Aeson @@ -65,340 +64,315 @@ import Keiro.Prelude import Kiroku.Store.Types (EventType (..), StreamName (..)) -{- | The stable name of a workflow /definition/ (for example -@"orderFulfillment"@). Part of the journal stream name and of every -deterministic journal-event id, so it must not change for a given definition -across deploys. Prefer 'mkWorkflowName' for new code; the raw constructor is -kept for compatibility and can create ambiguous journal stream names if the -text contains structural separators such as @-@, @:@, or @#@. --} +-- | The stable name of a workflow /definition/ (for example +-- @"orderFulfillment"@). Part of the journal stream name and of every +-- deterministic journal-event id, so it must not change for a given definition +-- across deploys. Prefer 'mkWorkflowName' for new code; the raw constructor is +-- kept for compatibility and can create ambiguous journal stream names if the +-- text contains structural separators such as @-@, @:@, or @#@. newtype WorkflowName = WorkflowName {unWorkflowName :: Text} - deriving stock (Eq, Ord, Show, Generic) + deriving stock (Eq, Ord, Show, Generic) -{- | The id of a single workflow /instance/ (a UUID-as-text or any stable -caller-supplied string). Combined with the 'WorkflowName' it identifies the -instance's journal stream. Prefer 'mkWorkflowId' for new code; the raw -constructor is kept for compatibility and can create ambiguous journal stream -names if the text contains structural separators such as @:@ or @#@. --} +-- | The id of a single workflow /instance/ (a UUID-as-text or any stable +-- caller-supplied string). Combined with the 'WorkflowName' it identifies the +-- instance's journal stream. Prefer 'mkWorkflowId' for new code; the raw +-- constructor is kept for compatibility and can create ambiguous journal stream +-- names if the text contains structural separators such as @:@ or @#@. newtype WorkflowId = WorkflowId {unWorkflowId :: Text} - deriving stock (Eq, Ord, Show, Generic) + deriving stock (Eq, Ord, Show, Generic) data WorkflowIdentityError - = WorkflowNameEmpty - | WorkflowNameInvalidChar !Char !Text - | WorkflowIdEmpty - | WorkflowIdInvalidChar !Char !Text - deriving stock (Eq, Show, Generic) - -{- | Validated constructor for workflow names. + = WorkflowNameEmpty + | WorkflowNameInvalidChar !Char !Text + | WorkflowIdEmpty + | WorkflowIdInvalidChar !Char !Text + deriving stock (Eq, Show, Generic) -Rejects empty names and the structural separators @:@ (stream prefix), @-@ -(name/id boundary), and @#@ (generation suffix). Prefer camelCase compound -names such as @"orderFulfillment"@; the raw 'WorkflowName' constructor remains -available for compatibility. --} +-- | Validated constructor for workflow names. +-- +-- Rejects empty names and the structural separators @:@ (stream prefix), @-@ +-- (name/id boundary), and @#@ (generation suffix). Prefer camelCase compound +-- names such as @"orderFulfillment"@; the raw 'WorkflowName' constructor remains +-- available for compatibility. mkWorkflowName :: Text -> Either WorkflowIdentityError WorkflowName mkWorkflowName raw - | Text.null raw = Left WorkflowNameEmpty - | Just c <- Text.find (`elem` ([':', '-', '#'] :: [Char])) raw = - Left (WorkflowNameInvalidChar c raw) - | otherwise = Right (WorkflowName raw) - -{- | Validated constructor for workflow ids. + | Text.null raw = Left WorkflowNameEmpty + | Just c <- Text.find (`elem` ([':', '-', '#'] :: [Char])) raw = + Left (WorkflowNameInvalidChar c raw) + | otherwise = Right (WorkflowName raw) -Rejects empty ids and the structural separators @:@ and @#@. The @-@ character -is permitted so UUID-style ids remain valid; with a validated, hyphen-free -workflow name, the @wf:\-\@ boundary is the first @-@. --} +-- | Validated constructor for workflow ids. +-- +-- Rejects empty ids and the structural separators @:@ and @#@. The @-@ character +-- is permitted so UUID-style ids remain valid; with a validated, hyphen-free +-- workflow name, the @wf:\-\@ boundary is the first @-@. mkWorkflowId :: Text -> Either WorkflowIdentityError WorkflowId mkWorkflowId raw - | Text.null raw = Left WorkflowIdEmpty - | Just c <- Text.find (`elem` ([':', '#'] :: [Char])) raw = - Left (WorkflowIdInvalidChar c raw) - | otherwise = Right (WorkflowId raw) + | Text.null raw = Left WorkflowIdEmpty + | Just c <- Text.find (`elem` ([':', '#'] :: [Char])) raw = + Left (WorkflowIdInvalidChar c raw) + | otherwise = Right (WorkflowId raw) -{- | The label identifying a step within a workflow. Replay matches on this -label, not on source position, so reordering code between deploys does not -corrupt an in-flight workflow. --} +-- | The label identifying a step within a workflow. Replay matches on this +-- label, not on source position, so reordering code between deploys does not +-- corrupt an in-flight workflow. newtype StepName = StepName {unStepName :: Text} - deriving stock (Eq, Ord, Show, Generic) + deriving stock (Eq, Ord, Show, Generic) -{- | The stable identifier of a /patch/ (EP-49) — a guarded, cross-cutting change -to a running workflow's logic. The author chooses an opaque, never-reused string -(for example @"fraud-check-v2"@). A patch decision is journaled under the key -@patch:\@, so the id must not contain the structural @:@ in a way that -makes the prefix boundary ambiguous, mirroring the 'sleepStepPrefix' caveat. --} +-- | The stable identifier of a /patch/ (EP-49) — a guarded, cross-cutting change +-- to a running workflow's logic. The author chooses an opaque, never-reused string +-- (for example @"fraud-check-v2"@). A patch decision is journaled under the key +-- @patch:\@, 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:\-\@. + deriving stock (Eq, Ord, Show, Generic) -The @:@ and @-@ characters are structural, and generation streams reserve @#@. -Use 'mkWorkflowName' and 'mkWorkflowId' for separator-safe identities. Raw -unvalidated names containing @-@ can make two distinct @(name, id)@ pairs share -one journal stream (the v1 process-manager @pm:\-\@ -convention carries the same caveat). --} +-- | 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). + StreamName ("wf:" <> name <> "-" <> wid) -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. --} +-- | 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. + | gen <= 0 = workflowStreamName name wid + | otherwise = + let StreamName base = workflowStreamName name wid + in StreamName (base <> "#" <> Text.pack (show gen)) -These last two are purely additive within @schemaVersion = 1@ (a new wire -tag added to 'workflowJournalCodec''s 'eventTypes'; old journals never carry -it, so no upcaster is needed). The codec is deliberately the single place to -extend. --} +-- | The events written to a workflow journal. +-- +-- * 'StepRecorded' — a step (identified by 'stepName') ran and produced +-- 'result' (the step's value encoded as JSON) at 'recordedAt'. The +-- suspension primitives journal their completions as ordinary +-- 'StepRecorded' events whose 'stepName' carries a reserved prefix +-- ('sleepStepPrefix', 'awakeableStepPrefix', 'childStepPrefix'); the +-- replay loop stays uniform because there is no separate event type. +-- * 'WorkflowCompleted' — the terminal marker appended once the whole +-- computation has returned. +-- * 'WorkflowCancelled' — a terminal marker (EP-43) written to a /child/ +-- workflow's journal by @cancelChild@; a run whose journal carries it +-- short-circuits without executing further steps and reports +-- 'Keiro.Workflow.Types.Cancelled'. +-- * 'WorkflowFailed' — a terminal failure marker (carries a 'reason'), +-- available for a worker to record a permanently-failed run. +-- +-- These last two are purely additive within @schemaVersion = 1@ (a new wire +-- tag added to 'workflowJournalCodec''s 'eventTypes'; old journals never carry +-- it, so no upcaster is needed). The codec is deliberately the single place to +-- extend. data WorkflowJournalEvent - = StepRecorded {stepName :: !Text, result :: !Aeson.Value, recordedAt :: !UTCTime} - | WorkflowCompleted {recordedAt :: !UTCTime} - | WorkflowCancelled {recordedAt :: !UTCTime} - | WorkflowFailed {reason :: !Text, recordedAt :: !UTCTime} - | {- | Terminal-for-this-generation rotation marker (EP-48). 'generation' - is the NEXT generation this rotation opens. Additive within - @schemaVersion = 1@: old journals never carry the - @"WorkflowContinuedAsNew"@ tag, so no upcaster is needed. - -} - WorkflowContinuedAsNew {generation :: !Int, recordedAt :: !UTCTime} - deriving stock (Eq, Show, Generic) + = StepRecorded {stepName :: !Text, result :: !Aeson.Value, recordedAt :: !UTCTime} + | WorkflowCompleted {recordedAt :: !UTCTime} + | WorkflowCancelled {recordedAt :: !UTCTime} + | WorkflowFailed {reason :: !Text, recordedAt :: !UTCTime} + | -- | Terminal-for-this-generation rotation marker (EP-48). 'generation' + -- is the NEXT generation this rotation opens. Additive within + -- @schemaVersion = 1@: old journals never carry the + -- @"WorkflowContinuedAsNew"@ tag, so no upcaster is needed. + WorkflowContinuedAsNew {generation :: !Int, recordedAt :: !UTCTime} + deriving stock (Eq, Show, Generic) -{- | The 'Codec' that serializes 'WorkflowJournalEvent' to and from the -JSON payloads stored on the journal stream. Schema version 1; no -upcasters. Each payload is self-describing (it carries a @"kind"@ -discriminator) so 'decode' can reconstruct the constructor from the -payload alone. --} +-- | The 'Codec' that serializes 'WorkflowJournalEvent' to and from the +-- JSON payloads stored on the journal stream. Schema version 1; no +-- upcasters. Each payload is self-describing (it carries a @"kind"@ +-- discriminator) so 'decode' can reconstruct the constructor from the +-- payload alone. workflowJournalCodec :: Codec WorkflowJournalEvent workflowJournalCodec = - Codec - { eventTypes = EventType "StepRecorded" :| [EventType "WorkflowCompleted", EventType "WorkflowCancelled", EventType "WorkflowFailed", EventType "WorkflowContinuedAsNew"] - , eventType = \case - StepRecorded{} -> EventType "StepRecorded" - WorkflowCompleted{} -> EventType "WorkflowCompleted" - WorkflowCancelled{} -> EventType "WorkflowCancelled" - WorkflowFailed{} -> EventType "WorkflowFailed" - WorkflowContinuedAsNew{} -> EventType "WorkflowContinuedAsNew" - , schemaVersion = 1 - , encode = encodeJournalEvent - , decode = decodeJournalEvent - , upcasters = [] - } + Codec + { eventTypes = EventType "StepRecorded" :| [EventType "WorkflowCompleted", EventType "WorkflowCancelled", EventType "WorkflowFailed", EventType "WorkflowContinuedAsNew"], + eventType = \case + StepRecorded {} -> EventType "StepRecorded" + WorkflowCompleted {} -> EventType "WorkflowCompleted" + WorkflowCancelled {} -> EventType "WorkflowCancelled" + WorkflowFailed {} -> EventType "WorkflowFailed" + WorkflowContinuedAsNew {} -> EventType "WorkflowContinuedAsNew", + schemaVersion = 1, + encode = encodeJournalEvent, + decode = decodeJournalEvent, + upcasters = [] + } encodeJournalEvent :: WorkflowJournalEvent -> Aeson.Value encodeJournalEvent = \case - StepRecorded name r t -> - Aeson.object - [ "kind" Aeson..= ("StepRecorded" :: Text) - , "stepName" Aeson..= name - , "result" Aeson..= r - , "recordedAt" Aeson..= t - ] - WorkflowCompleted t -> - Aeson.object - [ "kind" Aeson..= ("WorkflowCompleted" :: Text) - , "recordedAt" Aeson..= t - ] - WorkflowCancelled t -> - Aeson.object - [ "kind" Aeson..= ("WorkflowCancelled" :: Text) - , "recordedAt" Aeson..= t - ] - WorkflowFailed r t -> - Aeson.object - [ "kind" Aeson..= ("WorkflowFailed" :: Text) - , "reason" Aeson..= r - , "recordedAt" Aeson..= t - ] - WorkflowContinuedAsNew g t -> - Aeson.object - [ "kind" Aeson..= ("WorkflowContinuedAsNew" :: Text) - , "generation" Aeson..= g - , "recordedAt" Aeson..= t - ] + StepRecorded name r t -> + Aeson.object + [ "kind" Aeson..= ("StepRecorded" :: Text), + "stepName" Aeson..= name, + "result" Aeson..= r, + "recordedAt" Aeson..= t + ] + WorkflowCompleted t -> + Aeson.object + [ "kind" Aeson..= ("WorkflowCompleted" :: Text), + "recordedAt" Aeson..= t + ] + WorkflowCancelled t -> + Aeson.object + [ "kind" Aeson..= ("WorkflowCancelled" :: Text), + "recordedAt" Aeson..= t + ] + WorkflowFailed r t -> + Aeson.object + [ "kind" Aeson..= ("WorkflowFailed" :: Text), + "reason" Aeson..= r, + "recordedAt" Aeson..= t + ] + WorkflowContinuedAsNew g t -> + Aeson.object + [ "kind" Aeson..= ("WorkflowContinuedAsNew" :: Text), + "generation" Aeson..= g, + "recordedAt" Aeson..= t + ] decodeJournalEvent :: EventType -> Aeson.Value -> Either Text WorkflowJournalEvent decodeJournalEvent (EventType tag) value = first Text.pack (parseEither parser value) where parser = Aeson.withObject "WorkflowJournalEvent" $ \o -> do - case tag of - "StepRecorded" -> - StepRecorded <$> o Aeson..: "stepName" <*> o Aeson..: "result" <*> o Aeson..: "recordedAt" - "WorkflowCompleted" -> - WorkflowCompleted <$> o Aeson..: "recordedAt" - "WorkflowCancelled" -> - WorkflowCancelled <$> o Aeson..: "recordedAt" - "WorkflowFailed" -> - WorkflowFailed <$> o Aeson..: "reason" <*> o Aeson..: "recordedAt" - "WorkflowContinuedAsNew" -> - WorkflowContinuedAsNew <$> o Aeson..: "generation" <*> o Aeson..: "recordedAt" - other -> - fail ("unknown workflow journal event type: " <> Text.unpack other) - -{- | The accumulated step state a running workflow holds in memory: a map -from step name to that step's recorded JSON result. This is exactly the -value the journal carries, folded into a map. + case tag of + "StepRecorded" -> + StepRecorded <$> o Aeson..: "stepName" <*> o Aeson..: "result" <*> o Aeson..: "recordedAt" + "WorkflowCompleted" -> + WorkflowCompleted <$> o Aeson..: "recordedAt" + "WorkflowCancelled" -> + WorkflowCancelled <$> o Aeson..: "recordedAt" + "WorkflowFailed" -> + WorkflowFailed <$> o Aeson..: "reason" <*> o Aeson..: "recordedAt" + "WorkflowContinuedAsNew" -> + WorkflowContinuedAsNew <$> o Aeson..: "generation" <*> o Aeson..: "recordedAt" + other -> + fail ("unknown workflow journal event type: " <> Text.unpack other) -This alias is the integration contract EP-41 (snapshots) consumes; it must -remain a @Map Text Value@ whose keys are dynamic step-name strings. --} +-- | The accumulated step state a running workflow holds in memory: a map +-- from step name to that step's recorded JSON result. This is exactly the +-- value the journal carries, folded into a map. +-- +-- This alias is the integration contract EP-41 (snapshots) consumes; it must +-- remain a @Map Text Value@ whose keys are dynamic step-name strings. type WorkflowState = Map Text Aeson.Value -{- | The result of running a workflow. - -* 'Completed' — the computation ran to its end and a 'WorkflowCompleted' - event was journaled. -* 'Suspended' — the computation paused at an unresolved @awaitStep@; a - wake source was armed and the run will be resumed later (by EP-42's - resume worker) once the awaited result is journaled. - -* 'Cancelled' — the run's journal carried a 'WorkflowCancelled' marker (a - child cancelled by its parent, EP-43), so the handler short-circuited and - executed nothing further. Distinct from 'Suspended' (which will resume) and - 'Completed' (which finished its work). -* 'Failed' — the run's journal carried a 'WorkflowFailed' marker, so the - handler short-circuited and executed nothing further. --} +-- | The result of running a workflow. +-- +-- * 'Completed' — the computation ran to its end and a 'WorkflowCompleted' +-- event was journaled. +-- * 'Suspended' — the computation paused at an unresolved @awaitStep@; a +-- wake source was armed and the run will be resumed later (by EP-42's +-- resume worker) once the awaited result is journaled. +-- +-- * 'Cancelled' — the run's journal carried a 'WorkflowCancelled' marker (a +-- child cancelled by its parent, EP-43), so the handler short-circuited and +-- executed nothing further. Distinct from 'Suspended' (which will resume) and +-- 'Completed' (which finished its work). +-- * 'Failed' — the run's journal carried a 'WorkflowFailed' marker, so the +-- handler short-circuited and executed nothing further. data WorkflowOutcome a - = Completed a - | Suspended - | Cancelled - | Failed - | {- | EP-48: the run rotated onto a fresh journal generation via - @continueAsNew@; a subsequent run/resume of the same logical id - continues from the carried seed. Distinct from 'Suspended' (a wake - source is pending) and 'Completed' (the workflow is done): a rotated - workflow is still unfinished, so the resume worker re-invokes it and it - proceeds on the new generation. - -} - ContinuedAsNew - deriving stock (Eq, Show, Functor) + = Completed a + | Suspended + | Cancelled + | Failed + | -- | EP-48: the run rotated onto a fresh journal generation via + -- @continueAsNew@; a subsequent run/resume of the same logical id + -- continues from the carried seed. Distinct from 'Suspended' (a wake + -- source is pending) and 'Completed' (the workflow is done): a rotated + -- workflow is still unfinished, so the resume worker re-invokes it and it + -- proceeds on the new generation. + ContinuedAsNew + deriving stock (Eq, Show, Functor) -{- | The reserved step name written (as a 'WorkflowCompleted' journal event -and an index row) when a workflow finishes. The discovery query in -"Keiro.Workflow.Schema" ('Keiro.Workflow.Schema.findUnfinishedWorkflowIds') -treats a workflow lacking a row with this step name as unfinished, so the -literal here must match the literal in that SQL. --} +-- | The reserved step name written (as a 'WorkflowCompleted' journal event +-- and an index row) when a workflow finishes. The discovery query in +-- "Keiro.Workflow.Schema" ('Keiro.Workflow.Schema.findUnfinishedWorkflowIds') +-- treats a workflow lacking a row with this step name as unfinished, so the +-- literal here must match the literal in that SQL. completedStepName :: Text completedStepName = "__workflow_completed__" -{- | The reserved step name written (as a 'WorkflowCancelled' journal event and -an index row) when a workflow is cancelled. The replay handler short-circuits a -run that has a row with this step name, and -'Keiro.Workflow.Schema.findUnfinishedWorkflowIds' treats it (like -'completedStepName') as a terminal marker, so a cancelled workflow drops out of -resume discovery. The literal must match the literal in that SQL. --} +-- | The reserved step name written (as a 'WorkflowCancelled' journal event and +-- an index row) when a workflow is cancelled. The replay handler short-circuits a +-- run that has a row with this step name, and +-- 'Keiro.Workflow.Schema.findUnfinishedWorkflowIds' treats it (like +-- 'completedStepName') as a terminal marker, so a cancelled workflow drops out of +-- resume discovery. The literal must match the literal in that SQL. cancelledStepName :: Text cancelledStepName = "__workflow_cancelled__" -{- | The reserved step name written (as a 'WorkflowFailed' journal event and an -index row) when a workflow is recorded as permanently failed. --} +-- | The reserved step name written (as a 'WorkflowFailed' journal event and an +-- index row) when a workflow is recorded as permanently failed. failedStepName :: Text failedStepName = "__workflow_failed__" -{- | The reserved step name written (as a 'WorkflowContinuedAsNew' journal event -and an index row) when a workflow's generation rotates via @continueAsNew@ -(EP-48). Its presence on a generation's index row makes that generation terminal -/for itself/ (a rotated-away generation drops out of any per-generation -"unfinished" check); the /current/ generation is the one with no terminal marker -row. Distinct from 'completedStepName'/'cancelledStepName': a rotated workflow is -NOT finished — its work continues on the next generation — -so 'Keiro.Workflow.Schema.findUnfinishedWorkflowIds' deliberately scopes its -terminal-marker check to the current (MAX) generation and does not treat -'continuedAsNewStepName' as terminal for the logical workflow. --} +-- | The reserved step name written (as a 'WorkflowContinuedAsNew' journal event +-- and an index row) when a workflow's generation rotates via @continueAsNew@ +-- (EP-48). Its presence on a generation's index row makes that generation terminal +-- /for itself/ (a rotated-away generation drops out of any per-generation +-- "unfinished" check); the /current/ generation is the one with no terminal marker +-- row. Distinct from 'completedStepName'/'cancelledStepName': a rotated workflow is +-- NOT finished — its work continues on the next generation — +-- so 'Keiro.Workflow.Schema.findUnfinishedWorkflowIds' deliberately scopes its +-- terminal-marker check to the current (MAX) generation and does not treat +-- 'continuedAsNewStepName' as terminal for the logical workflow. continuedAsNewStepName :: Text continuedAsNewStepName = "__workflow_continued_as_new__" -{- | The reserved step name under which @continueAsNew@ (EP-48) carries the -author's seed value into the next generation. On rotation the runtime appends a -single @StepRecorded continueSeedStepName seedJson@ to the next generation's -journal (and snapshots it); the next run's body reads it back via @restoreSeed@ -— an ordinary journaled @step@ — so the carried state is restored without -re-running anything. The leading/trailing @__@ marks it reserved, like the -other @__workflow_*__@ names. --} +-- | The reserved step name under which @continueAsNew@ (EP-48) carries the +-- author's seed value into the next generation. On rotation the runtime appends a +-- single @StepRecorded continueSeedStepName seedJson@ to the next generation's +-- journal (and snapshots it); the next run's body reads it back via @restoreSeed@ +-- — an ordinary journaled @step@ — so the carried state is restored without +-- re-running anything. The leading/trailing @__@ marks it reserved, like the +-- other @__workflow_*__@ names. continueSeedStepName :: Text continueSeedStepName = "__workflow_seed__" -{- | Reserved step-name prefix EP-39 uses to journal a durable @sleep@'s -completion. Integration contract: EP-39 must use exactly this string. --} +-- | Reserved step-name prefix EP-39 uses to journal a durable @sleep@'s +-- completion. Integration contract: EP-39 must use exactly this string. sleepStepPrefix :: Text sleepStepPrefix = "sleep:" -{- | Reserved step-name prefix EP-40 uses to journal an awakeable's -completion. Integration contract: EP-40 must use exactly this string. --} +-- | Reserved step-name prefix EP-40 uses to journal an awakeable's +-- completion. Integration contract: EP-40 must use exactly this string. awakeableStepPrefix :: Text awakeableStepPrefix = "awk:" -{- | Reserved step-name prefix used to journal the random id allocated for an -awakeable. The id is random for new allocations but replay-stable because it is -recorded under @awkid:\@ before the workflow awaits @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. --} +-- | Reserved step-name prefix EP-43 uses to journal a child workflow's +-- completion. Integration contract: EP-43 must use exactly this string. childStepPrefix :: Text childStepPrefix = "child:" -{- | Reserved step-name prefix EP-49 uses to journal a 'patch' decision. A patch -decision is journaled as an ordinary 'StepRecorded' event whose 'stepName' is -@'patchStepPrefix' <> 'unPatchId' pid@ and whose 'result' is the JSON 'Bool' -branch decision, so the replay loop and the step index stay uniform — no new -journal-event constructor is added. --} +-- | Reserved step-name prefix EP-49 uses to journal a 'patch' decision. A patch +-- decision is journaled as an ordinary 'StepRecorded' event whose 'stepName' is +-- @'patchStepPrefix' <> 'unPatchId' pid@ and whose 'result' is the JSON 'Bool' +-- branch decision, so the replay loop and the step index stay uniform — no new +-- journal-event constructor is added. patchStepPrefix :: Text patchStepPrefix = "patch:" -{- | Reserved step name under which a workflow generation records the patch ids -that were active when that generation first started. --} +-- | Reserved step name under which a workflow generation records the patch ids +-- that were active when that generation first started. patchSetStepName :: Text patchSetStepName = "__workflow_patches__" diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -1,12807 +1,12808 @@ -module Main ( - main, -) -where - -import Contravariant.Extras (contrazip2, contrazip3, contrazip4, contrazip5, contrazip6) -import Control.Concurrent (forkIO, killThread, threadDelay) -import Control.Concurrent.MVar (MVar, modifyMVar, newEmptyMVar, newMVar, putMVar, readMVar, takeMVar, tryPutMVar) -import Control.Concurrent.STM (atomically, putTMVar) -import Control.Exception (ErrorCall, Exception, SomeException, displayException, evaluate, finally, throwIO, try) -import Data.Aeson (object, withObject, (.:), (.:?)) -import Data.Aeson qualified as Aeson -import Data.Aeson.KeyMap qualified as KeyMap -import Data.Aeson.Types (parseEither) -import Data.ByteString (ByteString) -import Data.IORef (IORef, atomicModifyIORef', modifyIORef', newIORef, readIORef, writeIORef) -import Data.Int (Int32) -import Data.List (isInfixOf) -import Data.Map.Strict qualified as Map -import Data.Monoid (mempty) -import Data.Set qualified as Set -import Data.Text qualified as Text -import Data.Text.Encoding qualified as TE -import Data.Time (NominalDiffTime, UTCTime (..), addUTCTime, diffUTCTime, secondsToDiffTime) -import Data.Time.Calendar (Day (ModifiedJulianDay)) -import Data.UUID (UUID, fromString, fromWords64) -import Data.UUID qualified as UUID -import Data.Vector qualified as Vector -import Data.Word (Word64) -import Effectful (Eff, IOE, (:>)) -import Effectful.Error.Static (Error, throwError) -import Effectful.Exception qualified as EffException -import GHC.Conc (ThreadStatus (..), threadStatus) -import Hasql.Decoders qualified as D -import Hasql.Encoders qualified as E -import Hasql.Statement (Statement, preparable) -import Keiki.Core ( - Edge (..), - HsPred (..), - InCtor (..), - IndexN, - RegFile (..), - SymTransducer (..), - Update (..), - WireCtor (..), - inpCtor, - lit, - matchInCtor, - oNil, - pack, - proj, - (*:), - (.==), - ) -import Keiki.Core qualified as Keiki -import Keiki.Generics (emptyRegFile) -import Keiki.Operators qualified as K -import Keiki.Shape (CanonicalStateShape) -import Keiro -import Keiro qualified as KeiroRoot -import Keiro.Codec.Structural ( - StructuralBinding (..), - bindingDomainRoundTrip, - bindingShapeRoundTrip, - decodeViaBinding, - encodeViaBinding, - ) -import Keiro.Connection (ensureProjectionSchema, qualifyTable, withProjectionSchema) -import Keiro.DeadLetter ( - DispatchDeadLetter (..), - DispatcherKind (..), - listDispatchDeadLetters, - recordDispatchDeadLetter, - ) -import Keiro.DeadLetter.Replay ( - ReplayOutcome (..), - ReplayResult (..), - listSubscriptionDeadLetters, - replaySubscriptionDeadLetters, - ) -import Keiro.EventStream (Terminality (..)) -import Keiro.EventStream.Validate ( - EventStreamWarning (..), - ValidatedEventStream, - mkEventStream, - mkEventStreamOrThrow, - mkEventStreamUnchecked, - mkEventStreamWith, - validateEventStream, - ) -import Keiro.Inbox ( - InboxDedupePolicy (..), - InboxError (..), - InboxPersistence (..), - InboxResult (..), - InboxStatus (..), - KafkaDeliveryRef (..), - garbageCollectCompleted, - listInbox, - lookupInbox, - markFailedTx, - runInboxTransaction, - runInboxTransactionBatch, - runInboxTransactionWith, - runInboxTransactionWithRetries, - runInboxTransactionWithRetriesWith, - sampleInboxBacklog, - ) -import Keiro.Inbox.Kafka qualified as InboxKafka -import Keiro.Integration.Event ( - IntegrationContentType (..), - IntegrationEvent (..), - SchemaReference (..), - TraceContext (..), - decodeJsonIntegrationEvent, - encodeJsonIntegrationEvent, - headerContentType, - headerMessageId, - headerSchemaSubject, - headerSchemaVersion, - headerSourceEventId, - headerSourceGlobalPosition, - headerTraceParent, - integrationHeaders, - integrationPayload, - parseContentType, - ) -import Keiro.Integration.Event qualified as IntegrationEvent -import Keiro.Outbox ( - BackoffSchedule (..), - ExponentialBackoffOptions (..), - IntegrationEventDraft (..), - IntegrationProducer (..), - IntegrationProducerConfigError (..), - OrderingPolicy (..), - OutboxId (..), - OutboxPublishConfigError (..), - OutboxRow (..), - OutboxStatus (..), - PublishOutcome (..), - claimOutboxBatch, - defaultMaintenanceOptions, - defaultPublishOptions, - draftToEvent, - enqueueIntegrationEventTx, - freshOutboxId, - garbageCollectSent, - lookupOutbox, - markOutboxSent, - mintIntegrationEvent, - mkIntegrationProducer, - mkOutboxPublishOptions, - outboxMaintenancePass, - publishClaimedOutbox, - sampleOutboxBacklog, - ) -import Keiro.Outbox.Kafka qualified as OutboxKafka -import Keiro.Outbox.Schema (markOutboxFailedTx) -import Keiro.Prelude -import Keiro.ProcessManager -import Keiro.Projection -import Keiro.ReadModel -import Keiro.ReadModel.Rebuild qualified as Rebuild -import Keiro.ReplayAudit qualified as ReplayAudit -import Keiro.Snapshot.Policy (shouldSnapshot, shouldSnapshotSpan) -import Keiro.Stream qualified as Stream -import Keiro.Subscription.Shard ( - ShardCountMismatch (..), - ShardLease (..), - WorkerId (..), - ensureShards, - fairShareTarget, - ) -import Keiro.Subscription.Shard.Schema ( - claimShardsTx, - ensureShardRows, - listShardOwnership, - releaseShardsTx, - renewLeaseTx, - ) -import Keiro.Subscription.Shard.Worker ( - ShardAck (..), - ShardWorkerError (..), - ShardedWorkerConfigError (..), - ShardedWorkerOptions (..), - acquireOutcome, - defaultShardedWorkerOptions, - mkShardedWorkerOptions, - reconcileShardsOnce, - runShardedSubscriptionGroup, - runShardedSubscriptionGroupAck, - ) -import Keiro.Telemetry qualified as Telemetry -import Keiro.Test.Postgres ( - StoreRunner (..), - withFreshResourceStore, - withFreshResourceStoreWith, - withFreshStore, - withFreshStoreWith, - withFreshStores2, - withMigratedSuite, - ) -import Keiro.Timer -import Keiro.Wake ( - WakeReason (..), - WakeSignal (..), - neverWake, - wakeSignalFromStore, - ) -import Keiro.Workflow ( - LeaseHeartbeat (..), - PatchId (..), - StepName (..), - Workflow, - WorkflowError (..), - WorkflowId (..), - WorkflowIdentityError (..), - WorkflowJournalEvent (StepRecorded, WorkflowCancelled, WorkflowCompleted, WorkflowContinuedAsNew, WorkflowFailed), - WorkflowLeaseLost (..), - WorkflowName (..), - WorkflowOutcome (..), - appendJournalEntry, - appendJournalEntryReturningId, - awaitStep, - awakeableAllocStepPrefix, - awakeableStepPrefix, - continueAsNew, - currentGeneration, - defaultWorkflowRunOptions, - findUnfinishedWorkflowIds, - loadStepIndex, - mkWorkflowId, - mkWorkflowName, - patch, - patchSetStepName, - patchStepName, - restoreSeed, - runWorkflow, - runWorkflowWith, - step, - stepExists, - workflowGenerationStreamName, - workflowJournalCodec, - ) -import Keiro.Workflow.Awakeable ( - AwakeableId (..), - WorkflowAwakeableCancelled (..), - awakeableIdText, - awakeableIdToUuid, - awakeableNamed, - cancelAwakeable, - deterministicAwakeableId, - signalAwakeable, - signalAwakeableFrom, - ) -import Keiro.Workflow.Awakeable.Schema qualified as Awk -import Keiro.Workflow.Child ( - ChildHandle (..), - WorkflowChildCancelled (..), - WorkflowChildFailed (..), - awaitChild, - cancelChild, - childCompletionHook, - childResultStepName, - childSpawnStepName, - runChildWorkflow, - spawnChild, - ) -import Keiro.Workflow.Child.Schema qualified as Child -import Keiro.Workflow.Gc qualified as WorkflowGc -import Keiro.Workflow.Instance qualified as Instance -import Keiro.Workflow.Resume ( - ResumeLogEvent (..), - ResumeSummary (..), - WorkflowDef (..), - defaultWorkflowResumeOptions, - emptyResumeSummary, - resumeWorkflowsOnce, - runPollLoopWith, - runWorkflowResumeWorkerPush, - runWorkflowResumeWorkerWith, - ) -import Keiro.Workflow.Sleep ( - matchSleepTimerGeneration, - parseSleepPayload, - runWorkflowTimerWorker, - sleepNamed, - sleepStepName, - sleepTimerId, - sleepTimerPayload, - workflowSleepFireAction, - ) -import Keiro.Workflow.Snapshot ( - loadWorkflowSnapshot, - workflowStateCodec, - ) -import Kiroku.Store qualified as Store -import Kiroku.Store.Effect (Store) -import Kiroku.Store.SQL qualified as KirokuSQL -import Kiroku.Store.Subscription.Stream (AckItem (..), subscriptionAckStream) -import Kiroku.Store.Subscription.Types ( - SubscriptionName (..), - SubscriptionTarget (..), - ) -import Kiroku.Store.Subscription.Types qualified as KirokuSub -import Kiroku.Store.Types ( - CategoryName (..), - EventData (..), - EventId (..), - EventType (..), - ExpectedVersion (..), - GlobalPosition (..), - RecordedEvent (..), - StreamId (..), - StreamName (..), - StreamVersion (..), - ) -import OpenTelemetry.Attributes (Attribute (..), Attributes, PrimitiveAttribute (..), lookupAttribute) -import OpenTelemetry.Attributes.Key (AttributeKey, unkey) -import OpenTelemetry.Exporter.InMemory.Metric (inMemoryMetricExporter) -import OpenTelemetry.Exporter.InMemory.Span (inMemoryListExporter) -import OpenTelemetry.Exporter.Metric ( - GaugeDataPoint (..), - HistogramDataPoint (..), - MetricExport (..), - NumberValue (..), - ResourceMetricsExport (..), - ScopeMetricsExport (..), - SumDataPoint (..), - ) -import OpenTelemetry.MeterProvider ( - SdkMeterProviderOptions (..), - createMeterProvider, - defaultSdkMeterProviderOptions, - ) -import OpenTelemetry.Metric.Core ( - forceFlushMeterProvider, - getMeter, - ) -import OpenTelemetry.Resource (emptyMaterializedResources) -import OpenTelemetry.Trace ( - SpanStatus (..), - createTracerProvider, - emptyTracerProviderOptions, - makeTracer, - shutdownTracerProvider, - tracerOptions, - ) -import OpenTelemetry.Trace.Core ( - ImmutableSpan (..), - Span, - SpanContext (..), - SpanHot (..), - SpanKind, - getSpanContext, - ) -import Shibuya.Adapter (Adapter (..)) -import Shibuya.Core.Ack (AckDecision (..), DeadLetterReason (..), HaltReason (..), RetryDelay (..)) -import Shibuya.Core.AckHandle (AckHandle (..)) -import Shibuya.Core.Ingested (Ingested (..)) -import Shibuya.Core.Types (Envelope (..)) -import Streamly.Data.Stream qualified as Streamly -import System.Exit (ExitCode (..)) -import System.Process (readProcessWithExitCode) -import System.Timeout (timeout) -import Test.Hspec -import "hasql-transaction" Hasql.Transaction qualified as Tx - -main :: IO () -main = withMigratedSuite $ \fixture -> hspec $ do - describe "Keiro" $ do - it "exposes the scaffold version" $ - KeiroRoot.version `shouldBe` ("0.4.0.0" :: Text) - - describe "Keiro.Telemetry metrics" $ do - it "records instrument names and values through an SDK meter" $ do - (exporter, ref) <- inMemoryMetricExporter - (provider, _env) <- - createMeterProvider - emptyMaterializedResources - defaultSdkMeterProviderOptions{metricExporter = Just exporter} - meter <- getMeter provider Telemetry.keiroInstrumentationLibrary - metrics <- Telemetry.newKeiroMetrics meter - let h = Just metrics - -- A counter (monotonic sum), a gauge (last value wins), a histogram. - Telemetry.recordOutboxPublished h 3 - Telemetry.recordOutboxPublished h 2 - Telemetry.recordOutboxBacklog h 7 - Telemetry.recordInboxDuplicates h 1 - Telemetry.recordTimerFireLag h 12.5 - _ <- forceFlushMeterProvider provider Nothing - exported <- readIORef ref - let scalars = flattenScalarPoints exported - hists = flattenHistogramPoints exported - -- The counter accumulated 3 + 2 = 5. - lookup "keiro.outbox.published" scalars `shouldBe` Just (IntNumber 5) - -- The gauge holds its last recorded value. - lookup "keiro.outbox.backlog" scalars `shouldBe` Just (IntNumber 7) - -- The duplicate counter holds 1. - lookup "keiro.inbox.duplicates" scalars `shouldBe` Just (IntNumber 1) - -- The histogram saw one observation summing to 12.5. - let lag = [(c, s) | (n, c, s) <- hists, n == "keiro.timer.fire.lag"] - lag `shouldBe` [(1, 12.5)] - -- Instruments we never recorded export no points. - lookup "keiro.timer.stuck" scalars `shouldBe` Nothing - - it "records nothing through a Nothing handle" $ do - (exporter, ref) <- inMemoryMetricExporter - (provider, _env) <- - createMeterProvider - emptyMaterializedResources - defaultSdkMeterProviderOptions{metricExporter = Just exporter} - -- A Nothing handle is the no-op path: helpers must short-circuit. - let h = Nothing - Telemetry.recordOutboxPublished h 99 - Telemetry.recordOutboxBacklog h 99 - Telemetry.recordTimerFireLag h 99.0 - _ <- forceFlushMeterProvider provider Nothing - exported <- readIORef ref - flattenScalarPoints exported `shouldBe` [] - flattenHistogramPoints exported `shouldBe` [] - - describe "Kiroku retry exhaustion observability" $ do - it "dead-letters after the configured delivery bound, emits the metric, and advances" $ do - (exporter, metricsRef) <- inMemoryMetricExporter - (provider, _env) <- - createMeterProvider - emptyMaterializedResources - defaultSdkMeterProviderOptions{metricExporter = Just exporter} - meter <- getMeter provider Telemetry.keiroInstrumentationLibrary - metrics <- Telemetry.newKeiroMetrics meter - forwarded <- newIORef (0 :: Int) - let observe _ = modifyIORef' forwarded (+ 1) - installBridge settings = - settings - & #eventHandler - .~ Just (Telemetry.kirokuEventBridge (Just metrics) observe) - withFreshStoreWith fixture installBridge $ \store -> do - total <- seedOrders store 1 2 - total `shouldBe` 2 - let subName = SubscriptionName "orders-retry-exhaustion" - subConfig = - ( KirokuSub.defaultSubscriptionConfig - subName - (Category (CategoryName "orders")) - (\_ -> pure KirokuSub.Continue) - ) - { KirokuSub.retryPolicy = KirokuSub.RetryPolicy 2 - } - pull label source = do - result <- timeout 5_000_000 (Streamly.uncons source) - case result of - Just (Just itemAndRest) -> pure itemAndRest - Just Nothing -> fail (label <> ": subscription ended early") - Nothing -> fail (label <> ": timed out waiting for delivery") - number item = - parseEither - (withObject "OrderPlaced" (.: "n")) - (ackEvent item ^. #payload) - (stream0, cancelStream) <- subscriptionAckStream store subConfig 4 - ( do - (first, stream1) <- pull "initial poison delivery" stream0 - ackAttempt first `shouldBe` 0 - number first `shouldBe` Right (0 :: Int) - atomically $ - putTMVar - (ackReply first) - (KirokuSub.Retry (KirokuSub.RetryDelay 0)) - - (retry, stream2) <- pull "poison redelivery" stream1 - ackAttempt retry `shouldBe` 1 - ackEvent retry ^. #eventId `shouldBe` ackEvent first ^. #eventId - atomically $ - putTMVar - (ackReply retry) - (KirokuSub.Retry (KirokuSub.RetryDelay 0)) - - (next, stream3) <- pull "event after exhausted poison" stream2 - ackAttempt next `shouldBe` 0 - number next `shouldBe` Right (1 :: Int) - ackEvent next ^. #eventId `shouldNotBe` ackEvent first ^. #eventId - atomically (putTMVar (ackReply next) KirokuSub.Stop) - ended <- timeout 5_000_000 (Streamly.uncons stream3) - case ended of - Just Nothing -> pure () - Just (Just _) -> expectationFailure "subscription delivered after Stop" - Nothing -> expectationFailure "subscription did not stop after the final acknowledgement" - ) - `finally` cancelStream - - Right rows <- - Store.runStoreIO store $ - Store.runTransaction $ - Tx.statement - ("orders-retry-exhaustion", 0) - KirokuSQL.readDeadLettersStmt - case Vector.toList rows of - [row] -> do - row ^. #deadLetterReason - `shouldBe` object - [ "kind" Aeson..= ("max_attempts_exceeded" :: Text) - , "attempts" Aeson..= (2 :: Int) - ] - row ^. #deadLetterReasonSummary `shouldBe` "max retry attempts exceeded (2)" - row ^. #deadLetterAttemptCount `shouldBe` 2 - other -> expectationFailure ("expected one Kiroku dead letter, got " <> show (Vector.length rows) <> ": " <> show other) - - _ <- forceFlushMeterProvider provider Nothing - exported <- readIORef metricsRef - lookup "keiro.subscription.deadlettered" (flattenScalarPoints exported) - `shouldBe` Just (IntNumber 1) - readIORef forwarded >>= (`shouldSatisfy` (> 1)) - - describe "Keiro.Stream" $ do - it "wraps and unwraps kiroku stream names" $ do - let orderStream = stream "order-123" :: Stream OrderStream - Stream.streamName orderStream `shouldBe` StreamName "order-123" - Stream.streamName (mapStreamName (\(StreamName name) -> StreamName (name <> "-archived")) orderStream) - `shouldBe` StreamName "order-123-archived" - - it "validates categories, rejecting the dash boundary and reserved names" $ do - fmap Stream.categoryText (Stream.category "incident" :: Either Stream.CategoryError (Stream.StreamCategory ())) - `shouldBe` Right "incident" - -- compound categories are camelCase; ':' (reserved for the wf: family) is also accepted - fmap Stream.categoryText (Stream.category "hospitalSurge" :: Either Stream.CategoryError (Stream.StreamCategory ())) - `shouldBe` Right "hospitalSurge" - fmap Stream.categoryText (Stream.category "wf:fulfillment" :: Either Stream.CategoryError (Stream.StreamCategory ())) - `shouldBe` Right "wf:fulfillment" - (Stream.category "" :: Either Stream.CategoryError (Stream.StreamCategory ())) - `shouldBe` Left Stream.CategoryEmpty - (Stream.category "hospital-surge" :: Either Stream.CategoryError (Stream.StreamCategory ())) - `shouldBe` Left (Stream.CategoryContainsSeparator "hospital-surge") - (Stream.category "$all" :: Either Stream.CategoryError (Stream.StreamCategory ())) - `shouldBe` Left (Stream.CategoryReserved "$all") - (Stream.category "ord ers" :: Either Stream.CategoryError (Stream.StreamCategory ())) - `shouldBe` Left (Stream.CategoryContainsIllegalChar ' ' "ord ers") - (Stream.category "ord\ners" :: Either Stream.CategoryError (Stream.StreamCategory ())) - `shouldBe` Left (Stream.CategoryContainsIllegalChar '\n' "ord\ners") - - it "builds entity streams that round-trip through kiroku's category rule" $ do - let cat = Stream.categoryUnsafe "orders" :: Stream.StreamCategory OrderStream - Stream.streamName (Stream.entityStream cat "1") `shouldBe` StreamName "orders-1" - Stream.categoryName cat `shouldBe` CategoryName "orders" - -- The category keiro reports equals kiroku's own parse of the produced - -- name, even when the id segment itself contains a dash. - Store.categoryName (Stream.streamName (Stream.entityStream cat "a-b-c")) - `shouldBe` Stream.categoryName cat - - it "entityStreamId renders ids via StreamIdSegment (Text and String)" $ do - let cat = Stream.categoryUnsafe "orders" :: Stream.StreamCategory OrderStream - Stream.streamName (Stream.entityStreamId cat ("o-1" :: Text)) `shouldBe` StreamName "orders-o-1" - Stream.streamName (Stream.entityStreamId cat ("o-1" :: String)) `shouldBe` StreamName "orders-o-1" - - it "rejects blank entity stream id segments" $ do - let cat = Stream.categoryUnsafe "orders" :: Stream.StreamCategory OrderStream - evaluate (Stream.streamName (Stream.entityStream cat "")) `shouldThrow` anyErrorCall - evaluate (Stream.streamName (Stream.entityStream cat " ")) `shouldThrow` anyErrorCall - - describe "Keiro.DeadLetter" $ around (withFreshStore fixture) $ do - it "records a dispatch dead letter idempotently" $ \storeHandle -> do - let deadLetter = - DispatchDeadLetter - { dispatcherKind = DispatcherProcessManager - , dispatcherName = "orders-pm" - , correlationId = "order-42" - , sourceEventId = EventId sampleUuid - , sourceGlobalPosition = GlobalPosition 17 - , emitIndex = 0 - , targetStreamName = StreamName "orders-42" - , errorClass = "command_rejected" - , errorDetail = Text.replicate 1100 "x" - , attemptCount = 2 - } - Right rows <- - Store.runStoreIO storeHandle $ do - recordDispatchDeadLetter deadLetter - recordDispatchDeadLetter deadLetter - listDispatchDeadLetters "orders-pm" - case rows of - [row] -> do - row ^. #dispatcherKind `shouldBe` DispatcherProcessManager - row ^. #dispatcherName `shouldBe` "orders-pm" - row ^. #correlationId `shouldBe` "order-42" - row ^. #sourceEventId `shouldBe` EventId sampleUuid - row ^. #sourceGlobalPosition `shouldBe` GlobalPosition 17 - row ^. #emitIndex `shouldBe` 0 - row ^. #targetStreamName `shouldBe` StreamName "orders-42" - row ^. #errorClass `shouldBe` "command_rejected" - Text.length (row ^. #errorDetail) `shouldBe` 1024 - row ^. #attemptCount `shouldBe` 2 - other -> expectationFailure ("expected one idempotent dead-letter row, got " <> show other) - - describe "Keiro.Codec" $ do - it "encodes current events with type tags and schema-version metadata" $ do - encoded <- shouldBeRight (encodeForAppend orderCodec (OrderPlaced "order-123" 5)) - encoded ^. #eventType `shouldBe` EventType "OrderPlaced" - encoded ^. #payload `shouldBe` object ["orderId" Aeson..= ("order-123" :: Text), "quantity" Aeson..= (5 :: Int)] - extractSchemaVersion (recordedFrom encoded) `shouldBe` Right 2 - - it "round-trips current events" $ do - encoded <- shouldBeRight (encodeForAppend orderCodec (OrderPlaced "order-123" 5)) - decodeRecorded orderCodec (recordedFrom encoded) `shouldBe` Right (OrderPlaced "order-123" 5) - - it "decodes by the stored tag, not by payload shape (H1)" $ do - let recorded = - recordedFrom - EventData - { eventId = Nothing - , eventType = EventType "CounterAudited" - , payload = object ["amount" Aeson..= (5 :: Int)] - , metadata = Just (metadataForOrDie 1 Nothing) - , causationId = Nothing - , correlationId = Nothing - } - decodeRecorded counterCodec recorded `shouldBe` Right (CounterAudited 5) - - it "runs upcasters in source-version order" $ - decodeRaw orderCodec (EventType "OrderPlaced") 1 (object ["orderId" Aeson..= ("order-123" :: Text), "qty" Aeson..= (5 :: Int)]) - `shouldBe` Right (OrderPlaced "order-123" 5) - - it "rejects gaps in upcaster chains" $ - decodeRaw gappyCodec (EventType "OrderPlaced") 1 (object ["orderId" Aeson..= ("order-123" :: Text), "qty" Aeson..= (5 :: Int)]) - `shouldBe` Left (GapInUpcasterChain 2 3) - - it "validates codec construction invariants" $ do - fmap (const ()) (mkCodec (orderCodec{schemaVersion = 0})) `shouldBe` Left (CodecSchemaVersionInvalid 0) - fmap (const ()) (mkCodec (orderCodec{eventTypes = EventType "OrderPlaced" :| [EventType "OrderPlaced"]})) - `shouldBe` Left (CodecDuplicateEventTypes [EventType "OrderPlaced"]) - fmap (const ()) (mkCodec (orderCodec{schemaVersion = 3, upcasters = [(1, const upcastOrderPlacedV1), (1, const upcastOrderPlacedV1)]})) - `shouldBe` Left (CodecDuplicateUpcasterSources [1]) - fmap (const ()) (mkCodec (orderCodec{schemaVersion = 3, upcasters = [(1, const upcastOrderPlacedV1)]})) - `shouldBe` Left (CodecUpcasterChainIncomplete [2] 3) - case mkCodec orderCodec of - Right _ -> pure () - Left err -> expectationFailure ("expected orderCodec to validate, got " <> show err) - - it "rejects future-version, malformed metadata, and incomplete upcaster chains" $ do - let v1Payload = object ["orderId" Aeson..= ("order-123" :: Text), "qty" Aeson..= (5 :: Int)] - earlyEndCodec = - orderCodec - { schemaVersion = 4 - , upcasters = [(1, const upcastOrderPlacedV1), (2, const Right)] - } - decodeRaw orderCodec (EventType "OrderPlaced") 3 v1Payload - `shouldBe` Left (VersionAhead 3 2) - decodeRaw earlyEndCodec (EventType "OrderPlaced") 1 v1Payload - `shouldBe` Left (IncompleteUpcasterChain 3 4) - - let malformedStamp = - recordedFrom - EventData - { eventId = Nothing - , eventType = EventType "OrderPlaced" - , payload = object ["orderId" Aeson..= ("order-123" :: Text), "quantity" Aeson..= (5 :: Int)] - , metadata = Just (object ["schemaVersion" Aeson..= ("2" :: Text)]) - , causationId = Nothing - , correlationId = Nothing - } - extractSchemaVersion malformedStamp - `shouldBe` Left (MalformedSchemaVersionStamp (Aeson.String "2")) - fmap (const ()) (encodeForAppendWithMetadata orderCodec (Just (Aeson.String "x")) (OrderPlaced "order-123" 5)) - `shouldBe` Left (NonObjectCallerMetadata (Aeson.String "x")) - - it "rejects recorded events with unknown type tags" $ do - let encoded = - recordedFrom - EventData - { eventId = Nothing - , eventType = EventType "OrderCancelled" - , payload = object ["orderId" Aeson..= ("order-123" :: Text)] - , metadata = Just (metadataForOrDie 2 Nothing) - , causationId = Nothing - , correlationId = Nothing - } - decodeRecorded orderCodec encoded - `shouldBe` Left (UnknownEventType (EventType "OrderCancelled") [EventType "OrderPlaced"]) - - describe "Keiro.Codec.Structural" $ do - let pairBinding :: StructuralBinding (Int, Bool) (Bool, Int) - pairBinding = - StructuralBinding - { bindingToShape = \(amount, enabled) -> (enabled, amount) - , bindingFromShape = \(enabled, amount) -> (amount, enabled) - } - encodePairShape (enabled, amount) = - object ["enabled" Aeson..= enabled, "amount" Aeson..= amount] - decodePairShape value = - case parseEither (withObject "PairShape" $ \objectValue -> (,) <$> objectValue .: "enabled" <*> objectValue .: "amount") value of - Left err -> Left (Text.pack err) - Right shape -> Right shape - - it "checks both total binding laws" $ do - bindingDomainRoundTrip pairBinding (7, True) `shouldBe` True - bindingShapeRoundTrip pairBinding (False, 9) `shouldBe` True - - it "delegates encoding to the generated shape codec" $ - encodeViaBinding pairBinding encodePairShape (7, True) - `shouldBe` object ["enabled" Aeson..= True, "amount" Aeson..= (7 :: Int)] - - it "propagates only shape decode failures before total construction" $ do - let encoded = object ["enabled" Aeson..= False, "amount" Aeson..= (9 :: Int)] - decodeViaBinding pairBinding decodePairShape encoded `shouldBe` Right (9, False) - decodeViaBinding pairBinding (const (Left "shape-error")) Aeson.Null - `shouldBe` Left "shape-error" - - describe "Keiro.EventStream" $ do - it "constructs an author-facing EventStream contract" $ do - let contract = - EventStream - { transducer = emptyTransducer - , initialState = Idle - , initialRegisters = RNil - , eventCodec = orderCodec - , resolveStreamName = \s -> Stream.streamName s - , snapshotPolicy = Never - , stateCodec = Nothing - } - typedStream = stream "order-123" :: Stream (EventStream () '[] OrderState OrderCommand OrderEvent) - contract ^. #initialState `shouldBe` Idle - (contract ^. #resolveStreamName) typedStream `shouldBe` StreamName "order-123" - - it "evaluates snapshot policies with explicit terminality" $ do - shouldSnapshot (Every 2) NotTerminal () (StreamVersion 0) `shouldBe` False - shouldSnapshot (Every 2) NotTerminal () (StreamVersion 2) `shouldBe` True - shouldSnapshot OnTerminal Terminal () (StreamVersion 1) `shouldBe` True - shouldSnapshot OnTerminal NotTerminal () (StreamVersion 1) `shouldBe` False - shouldSnapshot (Custom (\terminality _ _ -> terminality == Terminal)) Terminal () (StreamVersion 1) - `shouldBe` True - shouldSnapshot (Custom (\terminality _ _ -> terminality == Terminal)) NotTerminal () (StreamVersion 1) - `shouldBe` False - shouldSnapshotSpan (Every 3) NotTerminal () (StreamVersion 2) (StreamVersion 4) - `shouldBe` True - shouldSnapshotSpan (Every 3) NotTerminal () (StreamVersion 4) (StreamVersion 5) - `shouldBe` False - - it "rejects snapshot policies without a state codec" $ do - let contract :: CounterEventStream - contract = counterEventStreamDef{snapshotPolicy = Every 10, stateCodec = Nothing} - fmap (const ()) (mkEventStream "snapshotless" contract) - `shouldBe` Left [EventStreamWarning "snapshotless" "snapshotPolicy is set but stateCodec is Nothing; snapshots would never be written"] - - describe "EventStream replay-safety (validateEventStream)" $ do - it "every production-intent stream validates clean" $ - concat - [ validateEventStream "counter" counterEventStreamDef - , validateEventStream "counter-no-op" noOpCounterEventStreamDef - , validateEventStream "counter-multi" multiCounterEventStreamDef - , validateEventStream "counter-ambiguous" ambiguousCounterEventStreamDef - , validateEventStream "snapshot-counter" snapshotCounterEventStreamDef - , validateEventStream "snapshot-counter-multi" multiSnapshotCounterEventStreamDef - , validateEventStream "snapshot-counter-guarded" guardedSnapshotCounterEventStreamDef - , validateEventStream "pm-snapshot-counter" pmSnapshotCounterEventStreamDef - , validateEventStream "rejecting-counter" rejectingEventStreamDef - ] - `shouldBe` [] - - describe "mkEventStream" $ do - it "rejects duplicate upcaster sources at the stream boundary" $ do - let duplicateCodec = - counterCodec - { schemaVersion = 3 - , upcasters = [(1, const Right), (1, const Right)] - } - duplicateStream = counterEventStreamDef{eventCodec = duplicateCodec} - case mkEventStream "duplicate-codec" duplicateStream of - Left warnings -> do - map eswStreamLabel warnings `shouldSatisfy` all (== "duplicate-codec") - map eswReason warnings `shouldSatisfy` any (Text.isInfixOf "duplicate upcaster source version(s): 1") - Right _ -> expectationFailure "expected mkEventStream to reject duplicate upcaster sources" - - it "rejects a missing upcaster rung at the stream boundary" $ do - let incompleteCodec = - counterCodec - { schemaVersion = 3 - , upcasters = [(2, const Right)] - } - incompleteStream = counterEventStreamDef{eventCodec = incompleteCodec} - case mkEventStream "incomplete-codec" incompleteStream of - Left warnings -> do - map eswStreamLabel warnings `shouldSatisfy` all (== "incomplete-codec") - map eswReason warnings `shouldSatisfy` any (Text.isInfixOf "missing upcaster source version(s): 1") - Right _ -> expectationFailure "expected mkEventStream to reject an incomplete upcaster chain" - - it "includes the stream label when throwing for an invalid codec" $ do - let incompleteCodec = - counterCodec - { schemaVersion = 3 - , upcasters = [(2, const Right)] - } - incompleteStream = counterEventStreamDef{eventCodec = incompleteCodec} - result <- try @ErrorCall (evaluate (mkEventStreamOrThrow "throwing-incomplete-codec" incompleteStream)) - case result of - Left err -> do - displayException err `shouldSatisfy` isInfixOf "throwing-incomplete-codec" - displayException err `shouldSatisfy` isInfixOf "missing upcaster source version(s): 1" - Right _ -> expectationFailure "expected mkEventStreamOrThrow to reject an incomplete upcaster chain" - - it "keeps invalid codecs available through the unchecked escape hatch" $ do - let duplicateCodec = - counterCodec - { schemaVersion = 3 - , upcasters = [(1, const Right), (1, const Right)] - } - incompleteCodec = - counterCodec - { schemaVersion = 3 - , upcasters = [(2, const Right)] - } - _ <- evaluate (mkEventStreamUnchecked counterEventStreamDef{eventCodec = duplicateCodec}) - _ <- evaluate (mkEventStreamUnchecked counterEventStreamDef{eventCodec = incompleteCodec}) - pure () - - it "rejects a hidden-input stream by label" $ do - let warns = validateEventStream "broken" brokenHiddenInputEventStream - warns `shouldNotBe` [] - map eswStreamLabel warns `shouldSatisfy` all (== "broken") - map eswReason warns `shouldSatisfy` any (Text.isInfixOf "hidden-input") - case mkEventStream "broken" brokenHiddenInputEventStream of - Left ws -> do - map eswStreamLabel ws `shouldSatisfy` all (== "broken") - map eswReason ws `shouldSatisfy` any (Text.isInfixOf "hidden-input") - Right _ -> expectationFailure "expected mkEventStream to reject the hidden-input stream" - - it "rejects a head-unrecoverable multi-event stream" $ - expectValidationWarning - "head-unrecoverable" - "head-unrecoverable" - headUnrecoverableEventStreamDef - - it "rejects replay inversion ambiguity" $ - expectValidationWarning - "inversion-ambiguity" - "inversion-ambiguity" - inversionAmbiguousEventStreamDef - - it "rejects an unguarded command-field read" $ - expectValidationWarning - "unguarded-input-read" - "unguarded-input-read" - unguardedInputReadEventStreamDef - - it "rejects a silent edge that writes registers" $ do - Keiki.validateTransducer Keiki.defaultValidationOptions stateChangingEpsilonTransducer - `shouldSatisfy` any isStateChangingEpsilon - expectValidationWarning - "state-changing-epsilon" - "state-changing-epsilon" - stateChangingEpsilonEventStreamDef - - it "rejects a silent edge that changes vertex" $ do - Keiki.validateTransducer Keiki.defaultValidationOptions silentMoveTransducer - `shouldSatisfy` any isStateChangingEpsilon - expectValidationWarning - "silent-move" - "state-changing-epsilon" - silentMoveEventStreamDef - - it "keeps replay-contract checks enabled when caller options weaken them" $ do - case mkEventStreamWith - Keiki.defaultValidationOptions{Keiki.checkStateChangingEpsilon = False} - "silent-move-weakened" - silentMoveEventStreamDef of - Left warnings -> - map eswReason warnings - `shouldSatisfy` any (Text.isInfixOf "state-changing-epsilon") - Right _ -> expectationFailure "expected the durable boundary to restore the state-changing-epsilon check" - case mkEventStreamWith - Keiki.defaultValidationOptions{Keiki.checkHeadRecoverability = False} - "head-unrecoverable-weakened" - headUnrecoverableEventStreamDef of - Left warnings -> - map eswReason warnings - `shouldSatisfy` any (Text.isInfixOf "head-unrecoverable") - Right _ -> expectationFailure "expected the durable boundary to restore the head-recoverability check" - - it "provides a loudly named unchecked escape hatch" $ do - _ <- evaluate (mkEventStreamUnchecked silentMoveEventStreamDef) - pure () - - it "accepts every production-intent stream" $ do - let expectAccepted label eventStream = - case mkEventStream label eventStream of - Right _ -> pure () - Left ws -> expectationFailure ("expected mkEventStream to accept " <> Text.unpack label <> ", got " <> show ws) - expectAccepted "counter" counterEventStreamDef - expectAccepted "counter-no-op" noOpCounterEventStreamDef - expectAccepted "counter-multi" multiCounterEventStreamDef - expectAccepted "counter-ambiguous" ambiguousCounterEventStreamDef - expectAccepted "snapshot-counter" snapshotCounterEventStreamDef - expectAccepted "snapshot-counter-multi" multiSnapshotCounterEventStreamDef - expectAccepted "snapshot-counter-guarded" guardedSnapshotCounterEventStreamDef - expectAccepted "pm-snapshot-counter" pmSnapshotCounterEventStreamDef - expectAccepted "rejecting-counter" rejectingEventStreamDef - - it "rejects a snapshot codec whose initial register file contains an uninitialized slot" $ do - case mkEventStream "uninitialized-snapshot" uninitializedSnapshotEventStreamDef of - Left warns -> do - map eswStreamLabel warns `shouldSatisfy` all (== "uninitialized-snapshot") - map eswReason warns `shouldSatisfy` any (Text.isInfixOf "cannot encode the initial state/registers") - map eswReason warns `shouldSatisfy` any (Text.isInfixOf "uninit: neverWritten") - Right _ -> expectationFailure "expected mkEventStream to reject an uninitialized snapshot register" - - it "accepts the same snapshot stream when every initial register is initialized" $ do - case mkEventStream "initialized-snapshot" initializedSnapshotEventStreamDef of - Right _ -> pure () - Left warns -> expectationFailure ("expected initialized snapshot registers to validate, got " <> show warns) - - it "rejects a bare EventStream at runCommand (compile-time)" $ do - (exitCode, _stdout, stderr) <- - readProcessWithExitCode - "cabal" - [ "exec" - , "ghc" - , "--" - , "-fno-code" - , "-package" - , "keiro" - , "test/ReplaySafetyTypeProbe.hs" - ] - "" - exitCode `shouldSatisfy` (/= ExitSuccess) - stderr `shouldSatisfy` ("ValidatedEventStream" `isInfixOf`) - - describe "Keiro.Command" $ around (withFreshStore fixture) $ do - it "creates a stream and appends the first command event" $ \storeHandle -> do - let target = stream "counter-command-create" :: Stream CounterEventStream - result <- - Store.runStoreIO storeHandle $ - runCommand defaultRunCommandOptions counterEventStream target (Add 2) - case result of - Right (Right commandResult) -> do - commandResult ^. #streamVersion `shouldBe` StreamVersion 1 - commandResult ^. #eventsAppended `shouldBe` 1 - commandResult ^. #globalPosition `shouldSatisfy` isJust - other -> expectationFailure ("expected successful command, got " <> show other) - Right recorded <- - Store.runStoreIO storeHandle $ - Store.readStreamForward (StreamName "counter-command-create") (StreamVersion 0) 10 - Vector.length recorded `shouldBe` 1 - traverse (decodeRecorded counterCodec) (Vector.toList recorded) - `shouldBe` Right [CounterAdded 2] - - it "reports no global position for a no-op after prior events" $ \storeHandle -> do - let target = stream "skip-command-no-op-position" :: Stream SkipEventStream - Right (Right appended) <- - Store.runStoreIO storeHandle $ - runCommand defaultRunCommandOptions skipEventStream target (SAdd 2) - appended ^. #globalPosition `shouldSatisfy` isJust - result <- - Store.runStoreIO storeHandle $ - runCommand defaultRunCommandOptions skipEventStream target SSkip - case result of - Right (Right noOp) -> do - noOp ^. #streamVersion `shouldBe` StreamVersion 1 - noOp ^. #eventsAppended `shouldBe` 0 - noOp ^. #globalPosition `shouldBe` Nothing - other -> expectationFailure ("expected successful no-op command, got " <> show other) - - it "surfaces runtime edge ambiguity without appending" $ \storeHandle -> do - (processor, spansRef) <- inMemoryListExporter - provider <- createTracerProvider [processor] emptyTracerProviderOptions - let tracer = makeTracer provider "keiro-test" tracerOptions - target = stream "counter-command-ambiguous" :: Stream CounterEventStream - options = defaultRunCommandOptions & #tracer ?~ tracer - result <- - Store.runStoreIO storeHandle $ - runCommand options ambiguousCounterEventStream target (Add 1) - _ <- shutdownTracerProvider provider Nothing - result `shouldBe` Right (Left (CommandAmbiguous [0, 1])) - Right recorded <- - Store.runStoreIO storeHandle $ - Store.readStreamForward (StreamName "counter-command-ambiguous") (StreamVersion 0) 10 - recorded `shouldBe` Vector.empty - spans <- traverse captureSpan =<< readIORef spansRef - case spans of - [sp] -> textAttr (csAttributes sp) "error.type" `shouldBe` Just "command_ambiguous" - other -> expectationFailure ("expected one span, got " <> show (length other)) - - it "rehydrates prior events before appending a second command event" $ \storeHandle -> do - let target = stream "counter-command-update" :: Stream CounterEventStream - Right (Right _) <- - Store.runStoreIO storeHandle $ - runCommand defaultRunCommandOptions counterEventStream target (Add 2) - result <- - Store.runStoreIO storeHandle $ - runCommand defaultRunCommandOptions counterEventStream target (Add 3) - case result of - Right (Right commandResult) -> - commandResult ^. #streamVersion `shouldBe` StreamVersion 2 - other -> expectationFailure ("expected successful second command, got " <> show other) - Right recorded <- - Store.runStoreIO storeHandle $ - Store.readStreamForward (StreamName "counter-command-update") (StreamVersion 0) 10 - traverse (decodeRecorded counterCodec) (Vector.toList recorded) - `shouldBe` Right [CounterAdded 2, CounterAdded 3] - - it "rejects hydration after truncation without a covering snapshot" $ \storeHandle -> do - let target = stream "counter-truncated-uncovered" :: Stream CounterEventStream - targetName = StreamName "counter-truncated-uncovered" - Right (Right _) <- - Store.runStoreIO storeHandle $ - runCommand defaultRunCommandOptions counterEventStream target (Add 1) - Right (Right _) <- - Store.runStoreIO storeHandle $ - runCommand defaultRunCommandOptions counterEventStream target (Add 2) - Right (Right _) <- - Store.runStoreIO storeHandle $ - runCommand defaultRunCommandOptions counterEventStream target (Add 3) - Right (Just _) <- - Store.runStoreIO storeHandle $ - Store.setStreamTruncateBefore targetName (StreamVersion 3) - result <- - Store.runStoreIO storeHandle $ - runCommand defaultRunCommandOptions counterEventStream target (Add 4) - case result of - Right (Left (HydrationGapDetected expected observed)) -> do - expected `shouldBe` StreamVersion 1 - observed `shouldBe` StreamVersion 3 - other -> expectationFailure ("expected HydrationGapDetected, got " <> show other) - - it "rejects hydration when truncation lands inside a command batch" $ \storeHandle -> do - let target = stream "counter-truncated-mid-batch" :: Stream CounterEventStream - targetName = StreamName "counter-truncated-mid-batch" - Right (Right _) <- - Store.runStoreIO storeHandle $ - runCommand defaultRunCommandOptions multiCounterEventStream target (Add 1) - Right (Just _) <- - Store.runStoreIO storeHandle $ - Store.setStreamTruncateBefore targetName (StreamVersion 2) - result <- - Store.runStoreIO storeHandle $ - runCommand defaultRunCommandOptions multiCounterEventStream target (Add 2) - case result of - Right (Left (HydrationGapDetected expected observed)) -> do - expected `shouldBe` StreamVersion 1 - observed `shouldBe` StreamVersion 2 - other -> expectationFailure ("expected HydrationGapDetected, got " <> show other) - - it "hydrates normally after truncation covered by a snapshot" $ \storeHandle -> do - let target = stream "counter-truncated-covered" :: Stream SnapshotCounterEventStream - targetName = StreamName "counter-truncated-covered" - Right (Right _) <- - Store.runStoreIO storeHandle $ - runCommand defaultRunCommandOptions snapshotCounterEventStream target (Add 1) - Right (Right _) <- - Store.runStoreIO storeHandle $ - runCommand defaultRunCommandOptions snapshotCounterEventStream target (Add 2) - Right (Just _) <- - Store.runStoreIO storeHandle $ - Store.setStreamTruncateBefore targetName (StreamVersion 2) - result <- - Store.runStoreIO storeHandle $ - runCommand defaultRunCommandOptions snapshotCounterEventStream target (Add 3) - case result of - Right (Right commandResult) -> - commandResult ^. #streamVersion `shouldBe` StreamVersion 3 - other -> expectationFailure ("expected snapshot-covered command success, got " <> show other) - - it "uses caller-supplied event ids for idempotent command batches" $ \storeHandle -> do - let target = stream "counter-command-event-id" :: Stream CounterEventStream - supplied = EventId sampleUuid2 - options = defaultRunCommandOptions & #eventIds .~ [supplied] - result <- - Store.runStoreIO storeHandle $ - runCommand options counterEventStream target (Add 7) - case result of - Right (Right commandResult) -> - commandResult ^. #streamVersion `shouldBe` StreamVersion 1 - other -> expectationFailure ("expected successful command, got " <> show other) - Right recorded <- - Store.runStoreIO storeHandle $ - Store.readStreamForward (StreamName "counter-command-event-id") (StreamVersion 0) 10 - fmap (^. #eventId) (Vector.toList recorded) `shouldBe` [supplied] - - it "retries an optimistic conflict after rehydrating the winning event" $ \storeHandle -> do - conflictInserted <- newIORef False - let target = stream "counter-command-conflict" :: Stream CounterEventStream - conflictStreamName = StreamName "counter-command-conflict" - insertConflict = do - shouldInsert <- atomicModifyIORef' conflictInserted $ \alreadyInserted -> - if alreadyInserted - then (True, False) - else (True, True) - when shouldInsert $ do - encoded <- shouldBeRight (encodeForAppend counterCodec (CounterAdded 10)) - outcome <- - Store.runStoreIO storeHandle $ - Store.appendToStream conflictStreamName NoStream [encoded] - case outcome of - Right _ -> pure () - Left err -> expectationFailure ("failed to insert conflict event: " <> show err) - options = defaultRunCommandOptions & #beforeAppend .~ insertConflict - result <- - Store.runStoreIO storeHandle $ - runCommand options counterEventStream target (Add 2) - case result of - Right (Right commandResult) -> do - commandResult ^. #streamVersion `shouldBe` StreamVersion 2 - commandResult ^. #eventsAppended `shouldBe` 1 - other -> expectationFailure ("expected retry to succeed, got " <> show other) - Right recorded <- - Store.runStoreIO storeHandle $ - Store.readStreamForward conflictStreamName (StreamVersion 0) 10 - traverse (decodeRecorded counterCodec) (Vector.toList recorded) - `shouldBe` Right [CounterAdded 10, CounterAdded 2] - - it "reports true retry attempts and command conflict metrics when the retry budget is exhausted" $ \storeHandle -> do - (exporter, metricsRef) <- inMemoryMetricExporter - (provider, _env) <- - createMeterProvider - emptyMaterializedResources - defaultSdkMeterProviderOptions{metricExporter = Just exporter} - meter <- getMeter provider Telemetry.keiroInstrumentationLibrary - keiroMetrics <- Telemetry.newKeiroMetrics meter - let target = stream "counter-command-exhausted-conflict" :: Stream CounterEventStream - conflictStreamName = StreamName "counter-command-exhausted-conflict" - insertConflict = do - encoded <- shouldBeRight (encodeForAppend counterCodec (CounterAdded 10)) - outcome <- - Store.runStoreIO storeHandle $ - Store.appendToStream conflictStreamName AnyVersion [encoded] - case outcome of - Right _ -> pure () - Left err -> expectationFailure ("failed to insert conflict event: " <> show err) - options = - defaultRunCommandOptions - & #beforeAppend - .~ insertConflict - & #retryLimit - .~ 2 - & #retryBackoffMicros - .~ 0 - & #metrics - ?~ keiroMetrics - result <- - Store.runStoreIO storeHandle $ - runCommand options counterEventStream target (Add 2) - case result of - Right (Left (RetryExhausted attempts _)) -> - attempts `shouldBe` 3 - other -> expectationFailure ("expected exhausted retry budget, got " <> show other) - _ <- forceFlushMeterProvider provider Nothing - exported <- readIORef metricsRef - let scalars = flattenScalarPoints exported - lookup "keiro.command.conflicts" scalars `shouldBe` Just (IntNumber 3) - lookup "keiro.command.retries" scalars `shouldBe` Just (IntNumber 2) - - it "records the successful retry attempt on the command span" $ \storeHandle -> do - (processor, spansRef) <- inMemoryListExporter - provider <- createTracerProvider [processor] emptyTracerProviderOptions - conflictInserted <- newIORef False - let tracer = makeTracer provider "keiro-test" tracerOptions - target = stream "counter-command-retry-span" :: Stream CounterEventStream - conflictStreamName = StreamName "counter-command-retry-span" - insertConflict = do - shouldInsert <- atomicModifyIORef' conflictInserted $ \alreadyInserted -> - if alreadyInserted - then (True, False) - else (True, True) - when shouldInsert $ do - encoded <- shouldBeRight (encodeForAppend counterCodec (CounterAdded 10)) - outcome <- - Store.runStoreIO storeHandle $ - Store.appendToStream conflictStreamName NoStream [encoded] - case outcome of - Right _ -> pure () - Left err -> expectationFailure ("failed to insert conflict event: " <> show err) - options = - defaultRunCommandOptions - & #beforeAppend - .~ insertConflict - & #retryBackoffMicros - .~ 0 - & #tracer - ?~ tracer - Right (Right _) <- - Store.runStoreIO storeHandle $ - runCommand options counterEventStream target (Add 2) - _ <- shutdownTracerProvider provider Nothing - spans <- traverse captureSpan =<< readIORef spansRef - case spans of - [sp] -> - case lookupAttribute (csAttributes sp) "keiro.retry.attempt" of - Just (AttributeValue (IntAttribute n)) -> n `shouldBe` 2 - other -> expectationFailure ("expected retry attempt attribute 2, got " <> show other) - other -> expectationFailure ("expected one span, got " <> show (length other)) - - it "counts duplicate deterministic command events" $ \storeHandle -> do - (exporter, metricsRef) <- inMemoryMetricExporter - (provider, _env) <- - createMeterProvider - emptyMaterializedResources - defaultSdkMeterProviderOptions{metricExporter = Just exporter} - meter <- getMeter provider Telemetry.keiroInstrumentationLibrary - keiroMetrics <- Telemetry.newKeiroMetrics meter - let supplied = EventId sampleUuid3 - first = stream "counter-command-duplicate-a" :: Stream CounterEventStream - second = stream "counter-command-duplicate-b" :: Stream CounterEventStream - options = - defaultRunCommandOptions - & #eventIds - .~ [supplied] - & #metrics - ?~ keiroMetrics - Right (Right _) <- - Store.runStoreIO storeHandle $ - runCommand options counterEventStream first (Add 1) - result <- - Store.runStoreIO storeHandle $ - runCommand options counterEventStream second (Add 2) - case result of - Right (Left (StoreFailed Store.DuplicateEvent{})) -> pure () - other -> expectationFailure ("expected duplicate event failure, got " <> show other) - _ <- forceFlushMeterProvider provider Nothing - exported <- readIORef metricsRef - lookup "keiro.command.duplicates" (flattenScalarPoints exported) `shouldBe` Just (IntNumber 1) - - it "fails fast when a soft-deleted stream causes a conflict fixpoint" $ \storeHandle -> do - (exporter, metricsRef) <- inMemoryMetricExporter - (provider, _env) <- - createMeterProvider - emptyMaterializedResources - defaultSdkMeterProviderOptions{metricExporter = Just exporter} - meter <- getMeter provider Telemetry.keiroInstrumentationLibrary - keiroMetrics <- Telemetry.newKeiroMetrics meter - let target = stream "counter-command-soft-deleted" :: Stream CounterEventStream - options = - defaultRunCommandOptions - & #retryBackoffMicros - .~ 0 - & #metrics - ?~ keiroMetrics - Right (Right _) <- - Store.runStoreIO storeHandle $ - runCommand options counterEventStream target (Add 1) - Right (Just _) <- - Store.runStoreIO storeHandle $ - Store.softDeleteStream (StreamName "counter-command-soft-deleted") - result <- - Store.runStoreIO storeHandle $ - runCommand options counterEventStream target (Add 2) - case result of - Right (Left (ConflictFixpoint (StreamVersion 0) Store.StreamAlreadyExists{})) -> pure () - other -> expectationFailure ("expected conflict fixpoint, got " <> show other) - _ <- forceFlushMeterProvider provider Nothing - exported <- readIORef metricsRef - lookup "keiro.command.conflicts" (flattenScalarPoints exported) `shouldBe` Just (IntNumber 1) - - it "surfaces decode failure during hydration" $ \storeHandle -> do - Right _ <- - Store.runStoreIO storeHandle $ - Store.appendToStream - (StreamName "counter-command-decode-failure") - NoStream - [ EventData - { eventId = Nothing - , eventType = EventType "OtherEvent" - , payload = object [] - , metadata = Just (metadataForOrDie 1 Nothing) - , causationId = Nothing - , correlationId = Nothing - } - ] - let target = stream "counter-command-decode-failure" :: Stream CounterEventStream - result <- - Store.runStoreIO storeHandle $ - runCommand defaultRunCommandOptions counterEventStream target (Add 1) - result - `shouldBe` Right - (Left (HydrationDecodeFailed (UnknownEventType (EventType "OtherEvent") [EventType "CounterAdded", EventType "CounterAudited"]))) - - it "surfaces a typed no-inverting-edge hydration failure" $ \storeHandle -> do - let targetStreamName = StreamName "counter-command-no-inverting-edge" - target = stream "counter-command-no-inverting-edge" :: Stream CounterEventStream - appendCounterEvents storeHandle targetStreamName [CounterAudited 7] - result <- - Store.runStoreIO storeHandle $ - runCommand defaultRunCommandOptions counterEventStream target (Add 1) - result - `shouldBe` Right - (Left (HydrationReplayFailed (StreamVersion 1) HydrationNoInvertingEdge)) - - it "fails hydration after guard tightening without a replay-only twin (plan 143 reproduction)" $ \storeHandle -> do - let target = stream "divert-black-acuity-bad" :: Stream DivertEventStream - Right (Right appended) <- - Store.runStoreIO storeHandle $ - runCommand defaultRunCommandOptions permissiveDivertEventStream target (ConfirmDivert True) - appended ^. #streamVersion `shouldBe` StreamVersion 1 - result <- - Store.runStoreIO storeHandle $ - runCommand defaultRunCommandOptions tightenedDivertEventStream target (ConfirmDivert False) - result - `shouldBe` Right - (Left (HydrationReplayFailed (StreamVersion 1) HydrationNoInvertingEdge)) - - it "replays black-acuity history through the replay-only twin and keeps serving the live rule" $ \storeHandle -> do - let target = stream "divert-black-acuity-good" :: Stream DivertEventStream - Right (Right appended) <- - Store.runStoreIO storeHandle $ - runCommand defaultRunCommandOptions permissiveDivertEventStream target (ConfirmDivert True) - appended ^. #streamVersion `shouldBe` StreamVersion 1 - result <- - Store.runStoreIO storeHandle $ - runCommand defaultRunCommandOptions twinDivertEventStream target (ConfirmDivert False) - case result of - Right (Right commandResult) -> do - commandResult ^. #streamVersion `shouldBe` StreamVersion 2 - commandResult ^. #eventsAppended `shouldBe` 1 - other -> - expectationFailure ("expected hydration through the twin to succeed, got " <> show other) - Right recorded <- - Store.runStoreIO storeHandle $ - Store.readStreamForward (StreamName "divert-black-acuity-good") (StreamVersion 0) 10 - traverse (decodeRecorded divertCodec) (Vector.toList recorded) - `shouldBe` Right [DivertConfirmed True, DivertConfirmed False] - - it "rejects a new command in the removed region under the twin-bearing machine" $ \storeHandle -> do - let target = stream "divert-black-acuity-removed" :: Stream DivertEventStream - Right (Right _) <- - Store.runStoreIO storeHandle $ - runCommand defaultRunCommandOptions permissiveDivertEventStream target (ConfirmDivert True) - result <- - Store.runStoreIO storeHandle $ - runCommand defaultRunCommandOptions twinDivertEventStream target (ConfirmDivert True) - result `shouldBe` Right (Left CommandRejected) - Right recorded <- - Store.runStoreIO storeHandle $ - Store.readStreamForward (StreamName "divert-black-acuity-removed") (StreamVersion 0) 10 - Vector.length recorded `shouldBe` 1 - - it "surfaces a typed queue-mismatch hydration failure with the failing version" $ \storeHandle -> do - let targetStreamName = StreamName "counter-command-queue-mismatch" - target = stream "counter-command-queue-mismatch" :: Stream CounterEventStream - appendCounterEvents storeHandle targetStreamName [CounterAdded 5, CounterAudited 6] - result <- - Store.runStoreIO storeHandle $ - runCommand defaultRunCommandOptions multiCounterEventStream target (Add 1) - result - `shouldBe` Right - (Left (HydrationReplayFailed (StreamVersion 2) HydrationQueueMismatch)) - - it "surfaces a truncated multi-event chain as HydrationTruncatedChain" $ \storeHandle -> do - let targetStreamName = StreamName "counter-command-truncated-chain" - target = stream "counter-command-truncated-chain" :: Stream CounterEventStream - appendCounterEvents storeHandle targetStreamName [CounterAdded 5] - result <- - Store.runStoreIO storeHandle $ - runCommand defaultRunCommandOptions multiCounterEventStream target (Add 1) - result - `shouldBe` Right - (Left (HydrationReplayFailed (StreamVersion 1) HydrationTruncatedChain)) - - it "surfaces ambiguous inversion during hydration" $ \storeHandle -> do - let targetStreamName = StreamName "counter-command-ambiguous-inversion" - target = stream "counter-command-ambiguous-inversion" :: Stream CounterEventStream - appendCounterEvents storeHandle targetStreamName [CounterAdded 3] - result <- - Store.runStoreIO storeHandle $ - runCommand defaultRunCommandOptions inversionAmbiguousEventStream target (Add 1) - result - `shouldBe` Right - (Left (HydrationReplayFailed (StreamVersion 1) HydrationAmbiguousInversion)) - - it "truncates command span error status descriptions" $ \storeHandle -> do - (processor, spansRef) <- inMemoryListExporter - provider <- createTracerProvider [processor] emptyTracerProviderOptions - let tracer = makeTracer provider "keiro-test" tracerOptions - longTag = Text.replicate 400 "x" - Right _ <- - Store.runStoreIO storeHandle $ - Store.appendToStream - (StreamName "counter-command-long-decode-failure") - NoStream - [ EventData - { eventId = Nothing - , eventType = EventType longTag - , payload = object [] - , metadata = Just (metadataForOrDie 1 Nothing) - , causationId = Nothing - , correlationId = Nothing - } - ] - let target = stream "counter-command-long-decode-failure" :: Stream CounterEventStream - options = defaultRunCommandOptions & #tracer ?~ tracer - _ <- - Store.runStoreIO storeHandle $ - runCommand options counterEventStream target (Add 1) - _ <- shutdownTracerProvider provider Nothing - spans <- traverse captureSpan =<< readIORef spansRef - case spans of - [sp] -> - case csStatus sp of - Error description -> Text.length description `shouldSatisfy` (<= 256) - other -> expectationFailure ("expected error span status, got " <> show other) - other -> expectationFailure ("expected one span, got " <> show (length other)) - - it "rolls back the append when inline SQL condemns the transaction" $ \_ -> - withFreshResourceStore fixture $ \(storeHandle, StoreRunner runner) -> do - let target = stream "counter-command-rollback" :: Stream CounterEventStream - result <- - runner $ - runCommandWithSql - defaultRunCommandOptions - counterEventStream - target - (Add 1) - (\_ -> Tx.condemn >> pure ("rolled-back" :: Text)) - case result of - Right (Right (_, Just "rolled-back")) -> pure () - other -> expectationFailure ("expected condemned transaction result, got " <> show other) - Right recorded <- - Store.runStoreIO storeHandle $ - Store.readStreamForward (StreamName "counter-command-rollback") (StreamVersion 0) 10 - recorded `shouldBe` Vector.empty - - it "appends all events emitted by one accepted command" $ \storeHandle -> do - let target = stream "counter-command-multi-create" :: Stream CounterEventStream - result <- - Store.runStoreIO storeHandle $ - runCommand defaultRunCommandOptions multiCounterEventStream target (Add 5) - case result of - Right (Right commandResult) -> do - commandResult ^. #streamVersion `shouldBe` StreamVersion 2 - commandResult ^. #eventsAppended `shouldBe` 2 - commandResult ^. #globalPosition `shouldSatisfy` isJust - other -> expectationFailure ("expected successful multi-event command, got " <> show other) - Right recorded <- - Store.runStoreIO storeHandle $ - Store.readStreamForward (StreamName "counter-command-multi-create") (StreamVersion 0) 10 - traverse (decodeRecorded counterCodec) (Vector.toList recorded) - `shouldBe` Right [CounterAdded 5, CounterAudited 5] - - it "counts and traces a just-appended batch that cannot replay" $ \storeHandle -> do - (exporter, metricsRef) <- inMemoryMetricExporter - (metricProvider, _env) <- - createMeterProvider - emptyMaterializedResources - defaultSdkMeterProviderOptions{metricExporter = Just exporter} - meter <- getMeter metricProvider Telemetry.keiroInstrumentationLibrary - keiroMetrics <- Telemetry.newKeiroMetrics meter - (processor, spansRef) <- inMemoryListExporter - tracerProvider <- createTracerProvider [processor] emptyTracerProviderOptions - let tracer = makeTracer tracerProvider "keiro-test" tracerOptions - target = stream "counter-command-replay-divergence" :: Stream CounterEventStream - options = - defaultRunCommandOptions - & #metrics - ?~ keiroMetrics - & #tracer - ?~ tracer - Right (Right commandResult) <- - Store.runStoreIO storeHandle $ - runCommand options headUnrecoverableEventStream target (Add 2) - commandResult ^. #streamVersion `shouldBe` StreamVersion 2 - commandResult ^. #eventsAppended `shouldBe` 2 - _ <- forceFlushMeterProvider metricProvider Nothing - exported <- readIORef metricsRef - lookup "keiro.snapshot.apply.divergence" (flattenScalarPoints exported) - `shouldBe` Just (IntNumber 1) - next <- - Store.runStoreIO storeHandle $ - runCommand defaultRunCommandOptions headUnrecoverableEventStream target (Add 3) - case next of - Right (Left HydrationReplayFailed{}) -> pure () - other -> expectationFailure ("expected the witnessed divergence to poison hydration, got " <> show other) - _ <- shutdownTracerProvider tracerProvider Nothing - spans <- traverse captureSpan =<< readIORef spansRef - case spans of - [sp] -> - textAttr (csAttributes sp) "keiro.replay.divergence" - `shouldBe` Just "event_index=0;reason=no_inverting_edge" - other -> expectationFailure ("expected one divergence span, got " <> show (length other)) - - it "skips replay verification for a snapshot-less stream when disabled" $ \storeHandle -> do - (exporter, metricsRef) <- inMemoryMetricExporter - (provider, _env) <- - createMeterProvider - emptyMaterializedResources - defaultSdkMeterProviderOptions{metricExporter = Just exporter} - meter <- getMeter provider Telemetry.keiroInstrumentationLibrary - keiroMetrics <- Telemetry.newKeiroMetrics meter - let target = stream "counter-command-replay-divergence-disabled" :: Stream CounterEventStream - options = - defaultRunCommandOptions - & #metrics - ?~ keiroMetrics - & #verifyReplayOnAppend - .~ False - Right (Right commandResult) <- - Store.runStoreIO storeHandle $ - runCommand options headUnrecoverableEventStream target (Add 2) - commandResult ^. #eventsAppended `shouldBe` 2 - _ <- forceFlushMeterProvider provider Nothing - exported <- readIORef metricsRef - lookup "keiro.snapshot.apply.divergence" (flattenScalarPoints exported) - `shouldBe` Nothing - - it "witnesses replay divergence on the transactional SQL append path" $ \_ -> - withFreshResourceStore fixture $ \(_storeHandle, StoreRunner runner) -> do - (exporter, metricsRef) <- inMemoryMetricExporter - (provider, _env) <- - createMeterProvider - emptyMaterializedResources - defaultSdkMeterProviderOptions{metricExporter = Just exporter} - meter <- getMeter provider Telemetry.keiroInstrumentationLibrary - keiroMetrics <- Telemetry.newKeiroMetrics meter - let target = stream "counter-command-replay-divergence-sql" :: Stream CounterEventStream - options = defaultRunCommandOptions & #metrics ?~ keiroMetrics - Right (Right (commandResult, Just ())) <- - runner $ - runCommandWithSqlEvents - options - headUnrecoverableEventStream - target - (Add 2) - (\_ _ -> pure ()) - commandResult ^. #eventsAppended `shouldBe` 2 - _ <- forceFlushMeterProvider provider Nothing - exported <- readIORef metricsRef - lookup "keiro.snapshot.apply.divergence" (flattenScalarPoints exported) - `shouldBe` Just (IntNumber 1) - - it "replays a prior multi-event command before appending the next batch" $ \storeHandle -> do - let target = stream "counter-command-multi-replay" :: Stream CounterEventStream - Right (Right _) <- - Store.runStoreIO storeHandle $ - runCommand defaultRunCommandOptions multiCounterEventStream target (Add 2) - result <- - Store.runStoreIO storeHandle $ - runCommand defaultRunCommandOptions multiCounterEventStream target (Add 3) - case result of - Right (Right commandResult) -> do - commandResult ^. #streamVersion `shouldBe` StreamVersion 4 - commandResult ^. #eventsAppended `shouldBe` 2 - other -> expectationFailure ("expected successful second multi-event command, got " <> show other) - Right recorded <- - Store.runStoreIO storeHandle $ - Store.readStreamForward (StreamName "counter-command-multi-replay") (StreamVersion 0) 10 - traverse (decodeRecorded counterCodec) (Vector.toList recorded) - `shouldBe` Right [CounterAdded 2, CounterAudited 2, CounterAdded 3, CounterAudited 3] - - it "passes the complete multi-event batch to inline SQL in append order" $ \_ -> - withFreshResourceStore fixture $ \(_storeHandle, StoreRunner runner) -> do - let target = stream "counter-command-multi-sql-events" :: Stream CounterEventStream - result <- - runner $ - runCommandWithSqlEvents - defaultRunCommandOptions - multiCounterEventStream - target - (Add 8) - (\pairs _ -> pure (Prelude.map Prelude.fst pairs)) - case result of - Right (Right (commandResult, Just observed)) -> do - commandResult ^. #streamVersion `shouldBe` StreamVersion 2 - commandResult ^. #eventsAppended `shouldBe` 2 - observed `shouldBe` [CounterAdded 8, CounterAudited 8] - other -> expectationFailure ("expected successful SQL multi-event command, got " <> show other) - - it "command metadata is merged into stored event metadata" $ \storeHandle -> do - let target = stream "counter-command-metadata" :: Stream CounterEventStream - opts = - defaultRunCommandOptions - & #metadata - ?~ object ["actor" Aeson..= ("agent-7" :: Text)] - Right (Right _) <- - Store.runStoreIO storeHandle $ - runCommand opts counterEventStream target (Add 4) - Right recorded <- - Store.runStoreIO storeHandle $ - Store.readStreamForward (StreamName "counter-command-metadata") (StreamVersion 0) 10 - case Vector.toList recorded of - [event] -> - event ^. #metadata - `shouldBe` Just (object ["actor" Aeson..= ("agent-7" :: Text), "schemaVersion" Aeson..= (1 :: Int)]) - other -> expectationFailure ("expected a single recorded event, got " <> show other) - - it "reconstructed RecordedEvents match the stored batch" $ \_ -> - withFreshResourceStore fixture $ \(storeHandle, StoreRunner runner) -> do - let target = stream "counter-reconstruct-fidelity" :: Stream CounterEventStream - opts = - defaultRunCommandOptions - & #metadata - ?~ object ["actor" Aeson..= ("agent-7" :: Text)] - Right (Right (_, Just pairs)) <- - runner $ - runCommandWithSqlEvents opts multiCounterEventStream target (Add 8) (\ps _ -> pure ps) - let reconstructed = Prelude.map Prelude.snd pairs - -- Read the stored events back from their source stream. - Right storedVec <- - Store.runStoreIO storeHandle $ - Store.readStreamForward (StreamName "counter-reconstruct-fidelity") (StreamVersion 0) 10 - let stored = Vector.toList storedVec - -- readStreamForward reports globalPosition 0 for stream reads, so take - -- the true global positions from a category read (the DB is fresh per - -- test, so category "counter" holds exactly this batch). - Right catVec <- - Store.runStoreIO storeHandle $ - Store.readCategory (CategoryName "counter") (GlobalPosition 0) 10 - let catList = Vector.toList catVec - Prelude.length reconstructed `shouldBe` 2 - Prelude.length stored `shouldBe` 2 - fmap (^. #eventId) reconstructed `shouldBe` fmap (^. #eventId) stored - fmap (^. #eventType) reconstructed `shouldBe` fmap (^. #eventType) stored - fmap (^. #streamVersion) reconstructed `shouldBe` fmap (^. #streamVersion) stored - fmap (^. #originalVersion) reconstructed `shouldBe` fmap (^. #originalVersion) stored - fmap (^. #originalStreamId) reconstructed `shouldBe` fmap (^. #originalStreamId) stored - fmap (^. #payload) reconstructed `shouldBe` fmap (^. #payload) stored - fmap (^. #metadata) reconstructed `shouldBe` fmap (^. #metadata) stored - fmap (^. #globalPosition) reconstructed `shouldBe` fmap (^. #globalPosition) catList - - it "runCommand emits a Command span with the stream name, db.system.name, and keiro.events.appended" $ \storeHandle -> do - (processor, spansRef) <- inMemoryListExporter - provider <- createTracerProvider [processor] emptyTracerProviderOptions - let tracer = makeTracer provider "keiro-test" tracerOptions - target = stream "counter-command-otel" :: Stream CounterEventStream - options = defaultRunCommandOptions & #tracer ?~ tracer - Right (Right commandResult) <- - Store.runStoreIO storeHandle $ - runCommand options counterEventStream target (Add 9) - commandResult ^. #streamVersion `shouldBe` StreamVersion 1 - _ <- shutdownTracerProvider provider Nothing - spans <- traverse captureSpan =<< readIORef spansRef - length spans `shouldBe` 1 - let sp = case spans of - (s : _) -> s - [] -> error "no command span captured" - csName sp `shouldBe` "counter-command-otel" - show (csKind sp) `shouldBe` "Internal" - textAttr (csAttributes sp) "keiro.stream.name" `shouldBe` Just "counter-command-otel" - textAttr (csAttributes sp) "db.system.name" `shouldBe` Just "postgresql" - -- keiro.events.appended is an Int64 attribute, not Text. - case lookupAttribute (csAttributes sp) "keiro.events.appended" of - Just (AttributeValue (IntAttribute n)) -> n `shouldBe` 1 - other -> expectationFailure ("expected IntAttribute 1, got " <> show other) - case csStatus sp of - Unset -> pure () - Ok -> pure () - other -> expectationFailure ("expected Unset/Ok, got " <> show other) - - describe "Keiro.Command enrichment parity" $ do - let addMarker eventData = pure (eventData & #metadata %~ injectMarker) - injectMarker = \case - Just (Aeson.Object fields) -> - Just (Aeson.Object (KeyMap.insert "enriched" (Aeson.Bool True) fields)) - _ -> Just (object ["enriched" Aeson..= True]) - installHook = #storeSettings . #enrichEvent ?~ addMarker - hasMarker = \case - Just (Aeson.Object fields) -> - KeyMap.lookup "enriched" fields == Just (Aeson.Bool True) - _ -> False - around (withFreshResourceStoreWith fixture installHook) $ - it "applies the store enrichment hook to both command append paths" $ \(_storeHandle, StoreRunner runner) -> do - let plainTarget = stream "enrich-plain" :: Stream CounterEventStream - transactionalTarget = stream "enrich-transactional" :: Stream CounterEventStream - Right (Right _) <- - runner $ - runCommand defaultRunCommandOptions counterEventStream plainTarget (Add 1) - Right (Right (_, Just callbackRecordeds)) <- - runner $ - runCommandWithSqlEvents - defaultRunCommandOptions - counterEventStream - transactionalTarget - (Add 1) - (\pairs _ -> pure (fmap snd pairs)) - Right plainEvents <- - runner $ - Store.readStreamForward (StreamName "enrich-plain") (StreamVersion 0) 10 - Right transactionalEvents <- - runner $ - Store.readStreamForward (StreamName "enrich-transactional") (StreamVersion 0) 10 - for_ (Vector.toList plainEvents <> Vector.toList transactionalEvents) $ \recorded -> - recorded ^. #metadata `shouldSatisfy` hasMarker - for_ callbackRecordeds $ \recorded -> - recorded ^. #metadata `shouldSatisfy` hasMarker - - describe "Keiro.Snapshot" $ around (withFreshStore fixture) $ do - it "reports an ErrorCall when strict encoding reaches an empty register slot" $ \_storeHandle -> do - result <- - encodeSnapshotStrict - (defaultStateCodec @SnapshotCounterRegs @CounterState 1) - (Counting, emptyRegFile @SnapshotCounterRegs) - case result of - Left err -> displayException err `shouldSatisfy` isInfixOf "uninit: lastAmount" - Right _ -> expectationFailure "expected strict snapshot encoding to fail on an empty register slot" - - it "writes a snapshot after policy threshold" $ \storeHandle -> do - let target = stream "snapshot-write-threshold" :: Stream SnapshotCounterEventStream - Right (Right _) <- - Store.runStoreIO storeHandle $ - runCommand defaultRunCommandOptions snapshotCounterEventStream target (Add 2) - Right (Right _) <- - Store.runStoreIO storeHandle $ - runCommand defaultRunCommandOptions snapshotCounterEventStream target (Add 3) - Right snapshotVersion <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ - Tx.statement "snapshot-write-threshold" snapshotVersionForStreamStmt - snapshotVersion `shouldBe` Just (StreamVersion 2) - - it "does not fail a committed command when the post-commit snapshot write fails" $ \storeHandle -> do - (exporter, metricsRef) <- inMemoryMetricExporter - (provider, _env) <- - createMeterProvider - emptyMaterializedResources - defaultSdkMeterProviderOptions{metricExporter = Just exporter} - meter <- getMeter provider Telemetry.keiroInstrumentationLibrary - keiroMetrics <- Telemetry.newKeiroMetrics meter - let target = stream "snapshot-write-failure-swallowed" :: Stream SnapshotCounterEventStream - options = defaultRunCommandOptions & #metrics ?~ keiroMetrics - Right (Right _) <- - Store.runStoreIO storeHandle $ - runCommand options snapshotCounterEventStream target (Add 2) - Right () <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ - Tx.sql "ALTER TABLE keiro.keiro_snapshots ADD CONSTRAINT keiro_snapshots_no_writes CHECK (false) NOT VALID" - result <- - Store.runStoreIO storeHandle $ - runCommand options snapshotCounterEventStream target (Add 3) - case result of - Right (Right commandResult) -> do - commandResult ^. #streamVersion `shouldBe` StreamVersion 2 - commandResult ^. #eventsAppended `shouldBe` 1 - other -> expectationFailure ("expected committed command despite snapshot failure, got " <> show other) - Right recorded <- - Store.runStoreIO storeHandle $ - Store.readStreamForward (StreamName "snapshot-write-failure-swallowed") (StreamVersion 0) 10 - traverse (decodeRecorded counterCodec) (Vector.toList recorded) - `shouldBe` Right [CounterAdded 2, CounterAdded 3] - Right snapshotVersionDuringFailure <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ - Tx.statement "snapshot-write-failure-swallowed" snapshotVersionForStreamStmt - snapshotVersionDuringFailure `shouldBe` Nothing - _ <- forceFlushMeterProvider provider Nothing - exported <- readIORef metricsRef - lookup "keiro.snapshot.write.failures" (flattenScalarPoints exported) `shouldBe` Just (IntNumber 1) - Right () <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ - Tx.sql "ALTER TABLE keiro.keiro_snapshots DROP CONSTRAINT keiro_snapshots_no_writes" - Right (Right _) <- - Store.runStoreIO storeHandle $ - runCommand options snapshotCounterEventStream target (Add 4) - Right (Right _) <- - Store.runStoreIO storeHandle $ - runCommand options snapshotCounterEventStream target (Add 5) - Right snapshotVersionAfterRecovery <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ - Tx.statement "snapshot-write-failure-swallowed" snapshotVersionForStreamStmt - snapshotVersionAfterRecovery `shouldBe` Just (StreamVersion 4) - - it "does not fail a committed command when strict snapshot encoding fails" $ \storeHandle -> do - (exporter, metricsRef) <- inMemoryMetricExporter - (provider, _env) <- - createMeterProvider - emptyMaterializedResources - defaultSdkMeterProviderOptions{metricExporter = Just exporter} - meter <- getMeter provider Telemetry.keiroInstrumentationLibrary - keiroMetrics <- Telemetry.newKeiroMetrics meter - let target = stream "snapshot-encode-failure-swallowed" :: Stream PartialSnapshotEventStream - options = defaultRunCommandOptions & #metrics ?~ keiroMetrics - result <- - Store.runStoreIO storeHandle $ - runCommand options partialSnapshotEventStream target (Add 7) - case result of - Right (Right commandResult) -> do - commandResult ^. #streamVersion `shouldBe` StreamVersion 1 - commandResult ^. #eventsAppended `shouldBe` 1 - other -> expectationFailure ("expected committed command despite snapshot encode failure, got " <> show other) - Right recorded <- - Store.runStoreIO storeHandle $ - Store.readStreamForward (StreamName "snapshot-encode-failure-swallowed") (StreamVersion 0) 10 - traverse (decodeRecorded counterCodec) (Vector.toList recorded) - `shouldBe` Right [CounterAdded 7] - Right snapshotVersion <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ - Tx.statement "snapshot-encode-failure-swallowed" snapshotVersionForStreamStmt - snapshotVersion `shouldBe` Nothing - _ <- forceFlushMeterProvider provider Nothing - exported <- readIORef metricsRef - let scalars = flattenScalarPoints exported - lookup "keiro.snapshot.encode.failures" scalars `shouldBe` Just (IntNumber 1) - lookup "keiro.snapshot.write.failures" scalars `shouldBe` Nothing - - it "hydrates from snapshot and replays only the tail" $ \storeHandle -> do - (exporter, metricsRef) <- inMemoryMetricExporter - (provider, _env) <- - createMeterProvider - emptyMaterializedResources - defaultSdkMeterProviderOptions{metricExporter = Just exporter} - meter <- getMeter provider Telemetry.keiroInstrumentationLibrary - keiroMetrics <- Telemetry.newKeiroMetrics meter - let target = stream "snapshot-tail-hydration" :: Stream SnapshotCounterEventStream - options = defaultRunCommandOptions & #metrics ?~ keiroMetrics - Right (Right _) <- - Store.runStoreIO storeHandle $ - runCommand options snapshotCounterEventStream target (Add 2) - Right (Right _) <- - Store.runStoreIO storeHandle $ - runCommand options snapshotCounterEventStream target (Add 3) - Right () <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ - Tx.statement - ( "snapshot-tail-hydration" - , (defaultStateCodec @SnapshotCounterRegs @CounterState 1 ^. #encode) - (Counting, RCons (Proxy @"lastAmount") 4 RNil) - ) - corruptSnapshotStateStmt - result <- - Store.runStoreIO storeHandle $ - runCommand options guardedSnapshotCounterEventStream target (Add 4) - case result of - Right (Right commandResult) -> - commandResult ^. #streamVersion `shouldBe` StreamVersion 3 - other -> expectationFailure ("expected snapshot-assisted command, got " <> show other) - _ <- forceFlushMeterProvider provider Nothing - exported <- readIORef metricsRef - lookup "keiro.snapshot.read.hits" (flattenScalarPoints exported) `shouldBe` Just (IntNumber 1) - - it "falls back when snapshot JSON is corrupt" $ \storeHandle -> do - (exporter, metricsRef) <- inMemoryMetricExporter - (provider, _env) <- - createMeterProvider - emptyMaterializedResources - defaultSdkMeterProviderOptions{metricExporter = Just exporter} - meter <- getMeter provider Telemetry.keiroInstrumentationLibrary - keiroMetrics <- Telemetry.newKeiroMetrics meter - let target = stream "snapshot-corrupt-json" :: Stream SnapshotCounterEventStream - options = defaultRunCommandOptions & #metrics ?~ keiroMetrics - Right (Right _) <- - Store.runStoreIO storeHandle $ - runCommand options snapshotCounterEventStream target (Add 2) - Right (Right _) <- - Store.runStoreIO storeHandle $ - runCommand options snapshotCounterEventStream target (Add 3) - Right () <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ - Tx.statement ("snapshot-corrupt-json", Aeson.String "bad") corruptSnapshotStateStmt - result <- - Store.runStoreIO storeHandle $ - runCommand options snapshotCounterEventStream target (Add 4) - case result of - Right (Right commandResult) -> - commandResult ^. #streamVersion `shouldBe` StreamVersion 3 - other -> expectationFailure ("expected corrupt snapshot fallback, got " <> show other) - _ <- forceFlushMeterProvider provider Nothing - exported <- readIORef metricsRef - let scalars = flattenScalarPoints exported - lookup "keiro.snapshot.decode.failures" scalars `shouldBe` Just (IntNumber 1) - lookup "keiro.snapshot.read.misses" scalars `shouldBe` Just (IntNumber 3) - - it "falls back when shape hash mismatches" $ \storeHandle -> do - (exporter, metricsRef) <- inMemoryMetricExporter - (provider, _env) <- - createMeterProvider - emptyMaterializedResources - defaultSdkMeterProviderOptions{metricExporter = Just exporter} - meter <- getMeter provider Telemetry.keiroInstrumentationLibrary - keiroMetrics <- Telemetry.newKeiroMetrics meter - let target = stream "snapshot-shape-mismatch" :: Stream SnapshotCounterEventStream - options = defaultRunCommandOptions & #metrics ?~ keiroMetrics - Right (Right _) <- - Store.runStoreIO storeHandle $ - runCommand options snapshotCounterEventStream target (Add 2) - Right (Right _) <- - Store.runStoreIO storeHandle $ - runCommand options snapshotCounterEventStream target (Add 3) - Right () <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ - Tx.statement ("snapshot-shape-mismatch", "stale-shape") corruptSnapshotShapeStmt - result <- - Store.runStoreIO storeHandle $ - runCommand options snapshotCounterEventStream target (Add 4) - case result of - Right (Right commandResult) -> - commandResult ^. #streamVersion `shouldBe` StreamVersion 3 - other -> expectationFailure ("expected stale shape fallback, got " <> show other) - _ <- forceFlushMeterProvider provider Nothing - exported <- readIORef metricsRef - let scalars = flattenScalarPoints exported - lookup "keiro.snapshot.read.misses" scalars `shouldBe` Just (IntNumber 3) - lookup "keiro.snapshot.decode.failures" scalars `shouldBe` Nothing - - it "invalidates a snapshot when the control-state shape changes" $ \storeHandle -> do - let targetStreamName = StreamName "snapshot-state-shape-change" - target = stream "snapshot-state-shape-change" :: Stream SnapshotCounterEventStream - Right (Right _) <- - Store.runStoreIO storeHandle $ - runCommand defaultRunCommandOptions snapshotCounterEventStream target (Add 2) - Right (Right _) <- - Store.runStoreIO storeHandle $ - runCommand defaultRunCommandOptions snapshotCounterEventStream target (Add 3) - lookupResult <- - Store.runStoreIO storeHandle $ - lookupSnapshotSeed - targetStreamName - (defaultStateCodec @SnapshotCounterRegs @CounterStateV2 1) - case lookupResult of - Right (SnapshotUnavailable SnapshotNotFound) -> pure () - _ -> expectationFailure "expected the changed control-state shape to miss the stored snapshot" - - it "uses the fold fingerprint as a snapshot discriminator" $ \storeHandle -> do - let targetStreamName = StreamName "snapshot-fold-fingerprint-lookup" - target = stream "snapshot-fold-fingerprint-lookup" :: Stream SnapshotCounterEventStream - foldV1Codec = - defaultStateCodecWithFold - @SnapshotCounterRegs - @CounterState - (FoldVersion "fold-v1") - 1 - foldV2Codec = - defaultStateCodecWithFold - @SnapshotCounterRegs - @CounterState - (FoldVersion "fold-v2") - 1 - Right (Right _) <- - Store.runStoreIO storeHandle $ - runCommand defaultRunCommandOptions foldV1SnapshotCounterEventStream target (Add 2) - Right (Right _) <- - Store.runStoreIO storeHandle $ - runCommand defaultRunCommandOptions foldV1SnapshotCounterEventStream target (Add 3) - sameFingerprint <- Store.runStoreIO storeHandle $ lookupSnapshotSeed targetStreamName foldV1Codec - case sameFingerprint of - Right (SnapshotHit seed) -> seed ^. #streamVersion `shouldBe` StreamVersion 2 - _ -> expectationFailure "expected an equal fold fingerprint to reuse the snapshot" - changedFingerprint <- Store.runStoreIO storeHandle $ lookupSnapshotSeed targetStreamName foldV2Codec - case changedFingerprint of - Right (SnapshotUnavailable SnapshotNotFound) -> pure () - _ -> expectationFailure "expected a changed fold fingerprint to miss the snapshot" - - it "composes the hand-owned fold version into the state discriminator" $ \_storeHandle -> do - let plain = defaultStateCodec @SnapshotCounterRegs @CounterState 1 - withFold = - defaultStateCodecWithFold - @SnapshotCounterRegs - @CounterState - (FoldVersion "fold-v1") - 1 - withFold ^. #stateShapeHash `shouldBe` (plain ^. #stateShapeHash <> ";fold=fold-v1") - withFold ^. #stateCodecVersion `shouldBe` plain ^. #stateCodecVersion - withFold ^. #shapeHash `shouldBe` plain ^. #shapeHash - - it "full-replays under a changed fold and persists the new discriminator" $ \storeHandle -> do - let targetStreamName = "snapshot-fold-fingerprint-e2e" - target = stream targetStreamName :: Stream SnapshotCounterEventStream - candidateCodec = - defaultStateCodecWithFold - @SnapshotCounterRegs - @CounterState - (FoldVersion "fold-v2") - 1 - Right (Right _) <- - Store.runStoreIO storeHandle $ - runCommand defaultRunCommandOptions foldV1SnapshotCounterEventStream target (Add 2) - Right (Right _) <- - Store.runStoreIO storeHandle $ - runCommand defaultRunCommandOptions foldV1SnapshotCounterEventStream target (Add 3) - case Keiki.applyEventsEither - foldV2SnapshotCounterTransducer - (Counting, RCons (Proxy @"lastAmount") 0 RNil) - [CounterAdded 2, CounterAdded 3] of - Right (_, RCons _ fullReplayLastAmount RNil) -> - fullReplayLastAmount `shouldBe` 4 - Left failure -> - expectationFailure ("expected full replay under fold v2, got " <> show failure) - candidateResult <- - Store.runStoreIO storeHandle $ - runCommand defaultRunCommandOptions foldV2SnapshotCounterEventStream target (Add 104) - case candidateResult of - Right (Right result) -> do - result ^. #streamVersion `shouldBe` StreamVersion 3 - result ^. #eventsAppended `shouldBe` 1 - other -> expectationFailure ("expected changed-fold full replay to accept probe command, got " <> show other) - Right storedStateShape <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ - Tx.statement targetStreamName snapshotStateShapeForStreamStmt - storedStateShape `shouldBe` Just (candidateCodec ^. #stateShapeHash) - - it "pins the manual-contract hazard when fold logic changes without a discriminator bump" $ \storeHandle -> do - let targetStreamName = StreamName "snapshot-fold-manual-contract" - target = stream "snapshot-fold-manual-contract" :: Stream SnapshotCounterEventStream - unchangedCodec = - defaultStateCodecWithFold - @SnapshotCounterRegs - @CounterState - (FoldVersion "fold-v1") - 1 - Right (Right _) <- - Store.runStoreIO storeHandle $ - runCommand defaultRunCommandOptions foldV1SnapshotCounterEventStream target (Add 2) - Right (Right _) <- - Store.runStoreIO storeHandle $ - runCommand defaultRunCommandOptions foldV1SnapshotCounterEventStream target (Add 3) - staleSeed <- Store.runStoreIO storeHandle $ lookupSnapshotSeed targetStreamName unchangedCodec - case staleSeed of - Right (SnapshotHit seed) -> - case seed ^. #registers of - RCons _ staleLastAmount RNil -> staleLastAmount `shouldBe` 3 - _ -> expectationFailure "expected the unchanged discriminator to serve the stale seed" - residualResult <- - Store.runStoreIO storeHandle $ - runCommand defaultRunCommandOptions foldV2WithoutFingerprintBumpEventStream target (Add 104) - residualResult `shouldBe` Right (Left CommandRejected) - - it "samples a stale accepted seed without failing the command or writing a snapshot" $ \storeHandle -> do - (exporter, metricsRef) <- inMemoryMetricExporter - (provider, _env) <- - createMeterProvider - emptyMaterializedResources - defaultSdkMeterProviderOptions{metricExporter = Just exporter} - meter <- getMeter provider Telemetry.keiroInstrumentationLibrary - keiroMetrics <- Telemetry.newKeiroMetrics meter - let targetName = "snapshot-seed-sampled-divergence" - target = stream targetName :: Stream SnapshotCounterEventStream - candidateStream :: ValidatedSnapshotCounterEventStream - candidateStream = - mkEventStreamOrThrow - "snapshot-counter-fold-v2-sampled" - (foldV2WithoutFingerprintBumpEventStreamDef & #snapshotPolicy .~ Never) - options = - defaultRunCommandOptions - & #metrics - ?~ keiroMetrics - & #seedVerifySampleRate - .~ 1 - Right (Right _) <- - Store.runStoreIO storeHandle $ - runCommand defaultRunCommandOptions foldV1SnapshotCounterEventStream target (Add 2) - Right (Right _) <- - Store.runStoreIO storeHandle $ - runCommand defaultRunCommandOptions foldV1SnapshotCounterEventStream target (Add 3) - result <- - Store.runStoreIO storeHandle $ - runCommand options candidateStream target (Add 4) - case result of - Right (Right commandResult) -> do - commandResult ^. #streamVersion `shouldBe` StreamVersion 3 - commandResult ^. #eventsAppended `shouldBe` 1 - other -> expectationFailure ("expected sampled verification to stay advisory, got " <> show other) - observed <- - timeout 5_000_000 $ - let awaitDivergence = do - _ <- forceFlushMeterProvider provider Nothing - exported <- readIORef metricsRef - case lookup "keiro.snapshot.seed.divergence" (flattenScalarPoints exported) of - Just (IntNumber 1) -> pure () - _ -> threadDelay 10_000 >> awaitDivergence - in awaitDivergence - observed `shouldBe` Just () - Right snapshotVersion <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ - Tx.statement targetName snapshotVersionForStreamStmt - snapshotVersion `shouldBe` Just (StreamVersion 2) - - it "disables sampled seed verification at rate zero" $ \storeHandle -> do - (exporter, metricsRef) <- inMemoryMetricExporter - (provider, _env) <- - createMeterProvider - emptyMaterializedResources - defaultSdkMeterProviderOptions{metricExporter = Just exporter} - meter <- getMeter provider Telemetry.keiroInstrumentationLibrary - keiroMetrics <- Telemetry.newKeiroMetrics meter - let targetName = "snapshot-seed-sampling-disabled" - target = stream targetName :: Stream SnapshotCounterEventStream - candidateStream :: ValidatedSnapshotCounterEventStream - candidateStream = - mkEventStreamOrThrow - "snapshot-counter-fold-v2-sampling-disabled" - (foldV2WithoutFingerprintBumpEventStreamDef & #snapshotPolicy .~ Never) - options = - defaultRunCommandOptions - & #metrics - ?~ keiroMetrics - & #seedVerifySampleRate - .~ 0 - Right (Right _) <- - Store.runStoreIO storeHandle $ - runCommand defaultRunCommandOptions foldV1SnapshotCounterEventStream target (Add 2) - Right (Right _) <- - Store.runStoreIO storeHandle $ - runCommand defaultRunCommandOptions foldV1SnapshotCounterEventStream target (Add 3) - Right (Right commandResult) <- - Store.runStoreIO storeHandle $ - runCommand options candidateStream target (Add 4) - commandResult ^. #streamVersion `shouldBe` StreamVersion 3 - threadDelay 100_000 - _ <- forceFlushMeterProvider provider Nothing - exported <- readIORef metricsRef - lookup "keiro.snapshot.seed.divergence" (flattenScalarPoints exported) `shouldBe` Nothing - Right snapshotVersion <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ - Tx.statement targetName snapshotVersionForStreamStmt - snapshotVersion `shouldBe` Just (StreamVersion 2) - - it "falls back after operator truncation" $ \storeHandle -> do - (exporter, metricsRef) <- inMemoryMetricExporter - (provider, _env) <- - createMeterProvider - emptyMaterializedResources - defaultSdkMeterProviderOptions{metricExporter = Just exporter} - meter <- getMeter provider Telemetry.keiroInstrumentationLibrary - keiroMetrics <- Telemetry.newKeiroMetrics meter - let target = stream "snapshot-operator-truncate" :: Stream SnapshotCounterEventStream - options = defaultRunCommandOptions & #metrics ?~ keiroMetrics - Right (Right _) <- - Store.runStoreIO storeHandle $ - runCommand options snapshotCounterEventStream target (Add 2) - Right (Right _) <- - Store.runStoreIO storeHandle $ - runCommand options snapshotCounterEventStream target (Add 3) - Right () <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ - Tx.sql "TRUNCATE keiro.keiro_snapshots" - result <- - Store.runStoreIO storeHandle $ - runCommand options snapshotCounterEventStream target (Add 4) - case result of - Right (Right commandResult) -> - commandResult ^. #streamVersion `shouldBe` StreamVersion 3 - other -> expectationFailure ("expected truncation fallback, got " <> show other) - _ <- forceFlushMeterProvider provider Nothing - exported <- readIORef metricsRef - let scalars = flattenScalarPoints exported - lookup "keiro.snapshot.read.misses" scalars `shouldBe` Just (IntNumber 3) - lookup "keiro.snapshot.decode.failures" scalars `shouldBe` Nothing - - it "writes snapshots after applying a complete multi-event command batch" $ \storeHandle -> do - let target = stream "snapshot-multi-event-batch" :: Stream SnapshotCounterEventStream - result <- - Store.runStoreIO storeHandle $ - runCommand defaultRunCommandOptions multiSnapshotCounterEventStream target (Add 9) - case result of - Right (Right commandResult) -> do - commandResult ^. #streamVersion `shouldBe` StreamVersion 2 - commandResult ^. #eventsAppended `shouldBe` 2 - other -> expectationFailure ("expected multi-event snapshot command, got " <> show other) - Right snapshotVersion <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ - Tx.statement "snapshot-multi-event-batch" snapshotVersionForStreamStmt - snapshotVersion `shouldBe` Just (StreamVersion 2) - - it "writes a snapshot when a multi-event append crosses an Every boundary" $ \storeHandle -> do - let target = stream "snapshot-multi-event-crosses-boundary" :: Stream SnapshotCounterEventStream - boundaryEventStream :: SnapshotCounterEventStream - boundaryEventStream = - snapshotCounterEventStreamDef - & #transducer - .~ multiSnapshotCounterTransducer - & #snapshotPolicy - .~ Every 3 - validatedBoundaryEventStream = mkEventStreamOrThrow "snapshot-multi-event-crosses-boundary" boundaryEventStream - Right (Right _) <- - Store.runStoreIO storeHandle $ - runCommand defaultRunCommandOptions validatedBoundaryEventStream target (Add 2) - Right firstSnapshotVersion <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ - Tx.statement "snapshot-multi-event-crosses-boundary" snapshotVersionForStreamStmt - firstSnapshotVersion `shouldBe` Nothing - result <- - Store.runStoreIO storeHandle $ - runCommand defaultRunCommandOptions validatedBoundaryEventStream target (Add 3) - case result of - Right (Right commandResult) -> - commandResult ^. #streamVersion `shouldBe` StreamVersion 4 - other -> expectationFailure ("expected successful boundary-crossing command, got " <> show other) - Right snapshotVersion <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ - Tx.statement "snapshot-multi-event-crosses-boundary" snapshotVersionForStreamStmt - snapshotVersion `shouldBe` Just (StreamVersion 4) - - it "allows an incompatible snapshot codec to replace a higher-version row" $ \storeHandle -> do - let target = stream "snapshot-codec-rollback-overwrite" :: Stream SnapshotCounterEventStream - Right (Right _) <- - Store.runStoreIO storeHandle $ - runCommand defaultRunCommandOptions snapshotCounterEventStream target (Add 1) - Right (Right _) <- - Store.runStoreIO storeHandle $ - runCommand defaultRunCommandOptions snapshotCounterEventStream target (Add 2) - Right (Right _) <- - Store.runStoreIO storeHandle $ - runCommand defaultRunCommandOptions snapshotCounterEventStream target (Add 3) - Right (Right _) <- - Store.runStoreIO storeHandle $ - runCommand defaultRunCommandOptions snapshotCounterEventStream target (Add 4) - Right snapshotVersionBefore <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ - Tx.statement "snapshot-codec-rollback-overwrite" snapshotVersionForStreamStmt - snapshotVersionBefore `shouldBe` Just (StreamVersion 4) - let rollbackCodec = defaultStateCodec @SnapshotCounterRegs @CounterState 2 - streamId <- - Store.runStoreIO storeHandle (Store.lookupStreamId (StreamName "snapshot-codec-rollback-overwrite")) >>= \case - Right (Just sid) -> pure sid - other -> expectationFailure ("expected stream id, got " <> show other) *> error "unreachable" - Right () <- - Store.runStoreIO storeHandle $ - writeSnapshotRow - SnapshotWrite - { streamId = streamId - , streamVersion = StreamVersion 2 - , state = (rollbackCodec ^. #encode) (Counting, RCons (Proxy @"lastAmount") 2 RNil) - , stateCodecVersion = rollbackCodec ^. #stateCodecVersion - , regfileShapeHash = rollbackCodec ^. #shapeHash - , stateShapeHash = rollbackCodec ^. #stateShapeHash - } - Right snapshotVersionAfter <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ - Tx.statement "snapshot-codec-rollback-overwrite" snapshotVersionForStreamStmt - snapshotVersionAfter `shouldBe` Just (StreamVersion 2) - - describe "Keiro.ReplayAudit" $ around (withFreshStore fixture) $ do - it "accepts only stream names in the configured category" $ \_ -> do - ReplayAudit.streamInCategory "counter" (StreamName "counter-one") - `shouldBe` (Just (Stream.Stream (StreamName "counter-one")) :: Maybe (Stream ())) - ReplayAudit.streamInCategory "counter" (StreamName "other-one") - `shouldBe` (Nothing :: Maybe (Stream ())) - - it "catches a removed inverting edge while skipping unaffected streams" $ \storeHandle -> do - let affectedTarget = - stream "auditremove-affected" :: Stream CounterEventStream - unaffectedTarget = - stream "auditremove-unaffected" :: Stream CounterEventStream - affected = - ReplayAudit.AffectedSet - { affectedEventTypes = Set.singleton (EventType "CounterAdded") - , includeSnapshotStreams = False - } - budget = ReplayAudit.defaultAuditBudget & #parallelism .~ 2 - candidateTarget = - ReplayAudit.AuditTarget - { eventStream = auditedCounterEventStream - , category = "auditremove" - , mkStream = Just . Stream.Stream - } - deployedTarget = - ReplayAudit.AuditTarget - { eventStream = counterEventStream - , category = "auditremove" - , mkStream = Just . Stream.Stream - } - Right (Right _) <- - Store.runStoreIO storeHandle $ - runCommand defaultRunCommandOptions counterEventStream affectedTarget (Add 7) - Right (Right _) <- - Store.runStoreIO storeHandle $ - runCommand defaultRunCommandOptions auditedCounterEventStream unaffectedTarget (Add 9) - - Right candidateReport <- - Store.runStoreIO storeHandle $ - ReplayAudit.auditStreams - (ReplayAudit.AuditTargeted affected) - budget - candidateTarget - candidateReport ^. #streamsSelected `shouldBe` 1 - candidateReport ^. #streamsSkipped `shouldBe` 1 - candidateReport ^. #failures `shouldBe` 1 - candidateReport ^. #divergences `shouldBe` 0 - candidateReport ^. #rejectedStreams `shouldBe` [] - case candidateReport ^. #results of - [ ReplayAudit.StreamAuditResult - _ - ( ReplayAudit.ReplayFailed - (HydrationReplayFailed _ HydrationNoInvertingEdge) - ) - ] -> pure () - other -> - expectationFailure - ("expected a no-inverting-edge audit failure, got " <> show other) - - Right deployedReport <- - Store.runStoreIO storeHandle $ - ReplayAudit.auditStreams - (ReplayAudit.AuditTargeted affected) - budget - deployedTarget - ReplayAudit.auditExitCode [deployedReport] `shouldBe` 0 - - Right eventsAfterAudit <- - Store.runStoreIO storeHandle $ - Store.readStreamForward - (StreamName "auditremove-affected") - (StreamVersion 0) - 10 - Vector.length eventsAfterAudit `shouldBe` 1 - - it "proves a replay-only twin preserves the stored guard-tightening history" $ \storeHandle -> do - let target = stream "divert-audit-replay-only" :: Stream DivertEventStream - affected = - ReplayAudit.AffectedSet - { affectedEventTypes = Set.singleton (EventType "DivertConfirmed") - , includeSnapshotStreams = False - } - budget = ReplayAudit.defaultAuditBudget & #parallelism .~ 1 - auditWith candidate = - ReplayAudit.auditStreams - (ReplayAudit.AuditTargeted affected) - budget - ReplayAudit.AuditTarget - { eventStream = candidate - , category = "divert" - , mkStream = Just . Stream.Stream - } - Right (Right _) <- - Store.runStoreIO storeHandle $ - runCommand defaultRunCommandOptions permissiveDivertEventStream target (ConfirmDivert True) - - Right withoutTwin <- - Store.runStoreIO storeHandle $ - auditWith tightenedDivertEventStream - withoutTwin ^. #results - `shouldBe` [ ReplayAudit.StreamAuditResult - (StreamName "divert-audit-replay-only") - ( ReplayAudit.ReplayFailed - (HydrationReplayFailed (StreamVersion 1) HydrationNoInvertingEdge) - ) - ] - ReplayAudit.auditExitCode [withoutTwin] `shouldBe` 1 - - Right withTwin <- - Store.runStoreIO storeHandle $ - auditWith twinDivertEventStream - withTwin ^. #results - `shouldBe` [ ReplayAudit.StreamAuditResult - (StreamName "divert-audit-replay-only") - ReplayAudit.ReplayOk - { ReplayAudit.streamVersion = StreamVersion 1 - , ReplayAudit.digest = Nothing - } - ] - ReplayAudit.auditExitCode [withTwin] `shouldBe` 0 - - it "reports a stale accepted snapshot seed as a divergence" $ \storeHandle -> do - let target = - stream "auditfold-stale" :: Stream SnapshotCounterEventStream - auditTarget = - ReplayAudit.AuditTarget - { eventStream = foldV2WithoutFingerprintBumpEventStream - , category = "auditfold" - , mkStream = Just . Stream.Stream - } - Right (Right _) <- - Store.runStoreIO storeHandle $ - runCommand defaultRunCommandOptions foldV1SnapshotCounterEventStream target (Add 7) - Right (Right _) <- - Store.runStoreIO storeHandle $ - runCommand defaultRunCommandOptions foldV1SnapshotCounterEventStream target (Add 8) - - Right outcome <- - Store.runStoreIO storeHandle $ - ReplayAudit.auditStream auditTarget target - case outcome of - ReplayAudit.SeedDivergence - { seedVersion = StreamVersion 2 - , seededDigest - , fullDigest - } -> - seededDigest `shouldNotBe` fullDigest - other -> - expectationFailure - ("expected a stale-seed divergence, got " <> show other) - - it "keeps clean digests stable and resumes without re-auditing" $ \storeHandle -> do - let targets = - [ stream "auditclean-one" :: Stream SnapshotCounterEventStream - , stream "auditclean-two" :: Stream SnapshotCounterEventStream - ] - affected = - ReplayAudit.AffectedSet - { affectedEventTypes = Set.singleton (EventType "CounterAdded") - , includeSnapshotStreams = False - } - auditTarget = - ReplayAudit.AuditTarget - { eventStream = snapshotCounterEventStream - , category = "auditclean" - , mkStream = Just . Stream.Stream - } - unbounded = ReplayAudit.defaultAuditBudget & #parallelism .~ 2 - for_ (zip targets [10, 20]) $ \(target, amount) -> do - Right (Right _) <- - Store.runStoreIO storeHandle $ - runCommand defaultRunCommandOptions snapshotCounterEventStream target (Add amount) - Right (Right _) <- - Store.runStoreIO storeHandle $ - runCommand defaultRunCommandOptions snapshotCounterEventStream target (Add (amount + 1)) - pure () - - Right firstFull <- - Store.runStoreIO storeHandle $ - ReplayAudit.auditStreams ReplayAudit.AuditFull unbounded auditTarget - Right secondFull <- - Store.runStoreIO storeHandle $ - ReplayAudit.auditStreams ReplayAudit.AuditFull unbounded auditTarget - firstFull ^. #streamsSelected `shouldBe` 2 - firstFull ^. #streamsSkipped `shouldBe` 0 - firstFull ^. #results `shouldBe` secondFull ^. #results - - Right firstPage <- - Store.runStoreIO storeHandle $ - ReplayAudit.auditStreams - (ReplayAudit.AuditTargeted affected) - (unbounded & #maxStreams ?~ 1) - auditTarget - firstPage ^. #streamsSelected `shouldBe` 1 - firstPage ^. #checkpoint `shouldSatisfy` isJust - Right secondPage <- - Store.runStoreIO storeHandle $ - ReplayAudit.auditStreams - (ReplayAudit.AuditTargeted affected) - ( unbounded - & #maxStreams - ?~ 1 - & #resumeFrom - .~ (firstPage ^. #checkpoint) - ) - auditTarget - secondPage ^. #streamsSelected `shouldBe` 1 - let firstNames = Set.fromList ((^. #streamName) <$> firstPage ^. #results) - secondNames = Set.fromList ((^. #streamName) <$> secondPage ^. #results) - Set.disjoint firstNames secondNames `shouldBe` True - firstNames <> secondNames - `shouldBe` Set.fromList (Stream.streamName <$> targets) - - Right targeted <- - Store.runStoreIO storeHandle $ - ReplayAudit.auditStreams - (ReplayAudit.AuditTargeted affected) - unbounded - auditTarget - targeted ^. #results `shouldBe` firstFull ^. #results - - describe "Keiro.Connection projection schema" $ - around (withFreshResourceStoreWith fixture (withProjectionSchema "app_reads")) $ do - it "places a read-model table in a configured schema, separate from keiro metadata" $ \(storeHandle, StoreRunner runner) -> do - -- qualifiedTableName builds the app's fully-qualified data table ref. - qualifiedTableName placedReadModel `shouldBe` "\"app_reads\".\"placed_counter\"" - - -- Create the app schema (opt-in) and the qualified read-model table. - Right () <- - Store.runStoreIO storeHandle $ do - ensureProjectionSchema "app_reads" - initializeRegisteredReadModel placedReadModel initializePlacedTable - - -- Drive a command with the inline projection that writes the app table. - let target = stream "placed-in-app-reads" :: Stream CounterEventStream - result <- - runner $ - runCommandWithProjections - defaultRunCommandOptions - counterEventStream - target - (Add 7) - [placedInlineProjection] - case result of - Right (Right _) -> pure () - other -> expectationFailure ("expected placed inline projection command, got " <> show other) - - -- Read it back through the configured-schema read model. - queryResult <- - Store.runStoreIO storeHandle $ - runQuery Nothing placedReadModel "placed" - queryResult `shouldBe` Right (Right 7) - - -- Prove placement: the app table is in app_reads, NOT in kiroku, and - -- Keiro's own metadata (keiro_read_models) is in the keiro schema. - Right (inApp, inKiroku, keiroMeta) <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ - (,,) - <$> Tx.statement ("app_reads", "placed_counter") pgTableCountStmt - <*> Tx.statement ("kiroku", "placed_counter") pgTableCountStmt - <*> Tx.statement ("keiro", "keiro_read_models") pgTableCountStmt - inApp `shouldBe` (1 :: Int) - inKiroku `shouldBe` (0 :: Int) - keiroMeta `shouldBe` (1 :: Int) - - describe "Keiro.ReadModel" $ around (withFreshStore fixture) $ do - it "queries inline projection with Eventual consistency" $ \_ -> - withFreshResourceStore fixture $ \(storeHandle, StoreRunner runner) -> do - Right () <- - Store.runStoreIO storeHandle $ - initializeRegisteredReadModel counterReadModel initializeCounterReadModelTable - let target = stream "read-model-inline" :: Stream CounterEventStream - result <- - runner $ - runCommandWithProjections - defaultRunCommandOptions - counterEventStream - target - (Add 5) - [counterInlineProjection] - case result of - Right (Right commandResult) -> - commandResult ^. #globalPosition `shouldSatisfy` isJust - other -> expectationFailure ("expected inline projection command, got " <> show other) - queryResult <- - Store.runStoreIO storeHandle $ - runQuery Nothing counterReadModel "inline" - queryResult `shouldBe` Right (Right 5) - - it "reads the minimum checkpoint across consumer-group subscription members" $ \storeHandle -> do - Right () <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ do - Tx.statement ("counter-read-model-sub", 1, 7) upsertSubscriptionCursorMemberStmt - Tx.statement ("counter-read-model-sub", 2, 3) upsertSubscriptionCursorMemberStmt - position <- - Store.runStoreIO storeHandle $ - readSubscriptionPosition "counter-read-model-sub" - position `shouldBe` Right (Just (GlobalPosition 3)) - - it "Strong returns immediately on an empty log" $ \storeHandle -> do - Right () <- - Store.runStoreIO storeHandle $ - initializeRegisteredReadModel counterReadModel initializeCounterReadModelTable - queryResult <- - Store.runStoreIO storeHandle $ - runQueryWith Nothing Strong counterReadModel "empty" - queryResult `shouldBe` Right (Right 0) - - it "Strong returns immediately when the subscription is already at the store head" $ \_ -> - withFreshResourceStore fixture $ \(storeHandle, StoreRunner runner) -> do - Right () <- - Store.runStoreIO storeHandle $ - initializeRegisteredReadModel counterReadModel initializeCounterReadModelTable - let target = stream "read-model-strong-at-head" :: Stream CounterEventStream - Right (Right commandResult) <- - runner $ - runCommandWithProjections - defaultRunCommandOptions - counterEventStream - target - (Add 5) - [counterInlineProjection] - globalPosition <- case commandResult ^. #globalPosition of - Just position -> pure position - Nothing -> expectationFailure "expected command global position" *> error "unreachable" - Right () <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ - Tx.statement ("counter-read-model-sub", globalPositionToInt globalPosition) upsertSubscriptionCursorStmt - queryResult <- - Store.runStoreIO storeHandle $ - runQueryWith Nothing Strong counterReadModel "inline" - queryResult `shouldBe` Right (Right 5) - - it "Strong blocks until the subscription reaches the store head captured at query start" $ \_ -> - withFreshResourceStore fixture $ \(storeHandle, StoreRunner runner) -> do - Right () <- - Store.runStoreIO storeHandle $ - initializeRegisteredReadModel counterReadModel initializeCounterReadModelTable - let target = stream "read-model-strong-blocking" :: Stream CounterEventStream - Right (Right commandResult) <- - runner $ - runCommandWithProjections - defaultRunCommandOptions - counterEventStream - target - (Add 6) - [counterInlineProjection] - globalPosition <- case commandResult ^. #globalPosition of - Just position -> pure position - Nothing -> expectationFailure "expected command global position" *> error "unreachable" - _ <- forkIO $ do - threadDelay 20000 - advanced <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ - Tx.statement ("counter-read-model-sub", globalPositionToInt globalPosition) upsertSubscriptionCursorStmt - case advanced of - Right () -> pure () - Left err -> expectationFailure ("failed to advance subscription cursor: " <> show err) - queryResult <- - Store.runStoreIO storeHandle $ - runQueryWith Nothing Strong counterReadModel "inline" - queryResult `shouldBe` Right (Right 6) - - it "Strong returns when its category is caught up despite another active category" $ \_ -> - withFreshResourceStore fixture $ \(storeHandle, StoreRunner runner) -> do - Right () <- - Store.runStoreIO storeHandle $ - initializeRegisteredReadModel counterReadModel initializeCounterReadModelTable - let counterTarget = stream "counter-strong-scope" :: Stream CounterEventStream - otherTarget = stream "otherload-1" :: Stream CounterEventStream - Right (Right counterResult) <- - runner $ - runCommandWithProjections - defaultRunCommandOptions - counterEventStream - counterTarget - (Add 8) - [counterInlineProjection] - counterPosition <- case counterResult ^. #globalPosition of - Just position -> pure position - Nothing -> expectationFailure "expected counter global position" *> error "unreachable" - Right () <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ - Tx.statement - ("counter-read-model-sub", globalPositionToInt counterPosition) - upsertSubscriptionCursorStmt - Right (Right _) <- - Store.runStoreIO storeHandle $ - runCommand defaultRunCommandOptions counterEventStream otherTarget (Add 1) - queryResult <- - Store.runStoreIO storeHandle $ - runQueryWith Nothing Strong counterCategoryReadModel "inline" - queryResult `shouldBe` Right (Right 8) - - it "inline projection populates actor and source_event_id from command metadata" $ \_ -> - withFreshResourceStore fixture $ \(storeHandle, StoreRunner runner) -> do - Right () <- - Store.runStoreIO storeHandle $ - initializeRegisteredReadModel counterReadModel initializeCounterReadModelTable - let target = stream "read-model-inline-metadata" :: Stream CounterEventStream - opts = - defaultRunCommandOptions - & #metadata - ?~ object ["actor" Aeson..= ("agent-7" :: Text)] - Right (Right _) <- - runner $ - runCommandWithProjections opts counterEventStream target (Add 5) [counterInlineProjection] - Right row <- - Store.runStoreIO storeHandle $ - Store.runTransaction (Tx.statement "inline" selectCounterMetaStmt) - -- selectCounterMetaStmt returns (amount, actor, source_event_id). - row `shouldSatisfy` \(amount, actor, srcId) -> - amount == 5 && actor == Just "agent-7" && isJust srcId - - it "waits for async projection cursor with PositionWait" $ \_ -> - withFreshResourceStore fixture $ \(storeHandle, StoreRunner runner) -> do - Right () <- - Store.runStoreIO storeHandle $ - initializeRegisteredReadModel counterReadModel initializeCounterReadModelTable - let target = stream "read-model-position-wait" :: Stream CounterEventStream - Right (Right commandResult) <- - runner $ - runCommandWithProjections - defaultRunCommandOptions - counterEventStream - target - (Add 3) - [counterInlineProjection] - globalPosition <- case commandResult ^. #globalPosition of - Just position -> pure position - Nothing -> expectationFailure "expected command global position" *> error "unreachable" - Right () <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ - Tx.statement ("counter-read-model-sub", globalPositionToInt globalPosition) upsertSubscriptionCursorStmt - queryResult <- - Store.runStoreIO storeHandle $ - runQueryWith - Nothing - (PositionWait (fastWaitOptions & #target .~ Just globalPosition)) - counterReadModel - "inline" - queryResult `shouldBe` Right (Right 3) - - it "times out when PositionWait target is not reached" $ \storeHandle -> do - Right () <- - Store.runStoreIO storeHandle $ - initializeRegisteredReadModel counterReadModel initializeCounterReadModelTable - Right () <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ - Tx.statement ("counter-read-model-sub", 1) upsertSubscriptionCursorStmt - queryResult <- - Store.runStoreIO storeHandle $ - runQueryWith - Nothing - (PositionWait (fastWaitOptions & #target .~ Just (GlobalPosition 5))) - counterReadModel - "timeout" - queryResult - `shouldBe` Right - (Left (ReadModelWaitTimeout "counter-read-model" (GlobalPosition 5) (GlobalPosition 1))) - - it "does not write the registry row on repeated read-model queries" $ \storeHandle -> do - Right () <- - Store.runStoreIO storeHandle $ - initializeRegisteredReadModel counterReadModel initializeCounterReadModelTable - Right (Right 0) <- - Store.runStoreIO storeHandle $ - runQuery Nothing counterReadModel "no-churn" - Right xminBefore <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ - Tx.statement "counter-read-model" readModelXminStmt - Right (Right 0) <- - Store.runStoreIO storeHandle $ - runQuery Nothing counterReadModel "no-churn" - Right xminAfter <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ - Tx.statement "counter-read-model" readModelXminStmt - xminAfter `shouldBe` xminBefore - - it "rejects an unregistered model without creating a registry row" $ \storeHandle -> do - let unregistered :: ReadModel Text Int - unregistered = counterReadModel & #name .~ ("never-registered" :: Text) - queryResult <- - Store.runStoreIO storeHandle $ - runQuery Nothing unregistered "missing" - queryResult `shouldBe` Right (Left (ReadModelUnregistered "never-registered")) - found <- - Store.runStoreIO storeHandle $ - lookupReadModel "never-registered" - found `shouldBe` Right Nothing - - it "handles concurrent explicit read-model registration" $ \storeHandle -> do - Right () <- - Store.runStoreIO storeHandle $ - Store.runTransaction initializeCounterReadModelTable - resultA <- newEmptyMVar - resultB <- newEmptyMVar - _ <- - forkIO $ - Store.runStoreIO storeHandle (registerReadModelDefinition counterReadModel) - >>= putMVar resultA - _ <- - forkIO $ - Store.runStoreIO storeHandle (registerReadModelDefinition counterReadModel) - >>= putMVar resultB - first <- takeMVar resultA - second <- takeMVar resultB - first `shouldBe` Right () - second `shouldBe` Right () - queryResult <- - Store.runStoreIO storeHandle $ - runQuery Nothing counterReadModel "concurrent" - queryResult `shouldBe` Right (Right 0) - - it "rejects stale read-model schema" $ \storeHandle -> do - Right () <- - Store.runStoreIO storeHandle $ - initializeRegisteredReadModel counterReadModel initializeCounterReadModelTable - Right (Right 0) <- - Store.runStoreIO storeHandle $ - runQuery Nothing counterReadModel "stale" - Right () <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ - Tx.statement ("counter-read-model", 99) updateReadModelVersionStmt - queryResult <- - Store.runStoreIO storeHandle $ - runQuery Nothing counterReadModel "stale" - queryResult - `shouldBe` Right - (Left (ReadModelStaleSchema "counter-read-model" 1 99 "counter-read-model-v1" "counter-read-model-v1")) - - it "surfaces unknown read-model statuses with the raw status text" $ \storeHandle -> do - Right () <- - Store.runStoreIO storeHandle $ - initializeRegisteredReadModel counterReadModel initializeCounterReadModelTable - Right (Right 0) <- - Store.runStoreIO storeHandle $ - runQuery Nothing counterReadModel "unknown-status" - Right () <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ - Tx.statement ("counter-read-model", "wedged") updateReadModelStatusStmt - queryResult <- - Store.runStoreIO storeHandle $ - runQuery Nothing counterReadModel "unknown-status" - queryResult - `shouldBe` Right - (Left (ReadModelNotLive "counter-read-model" (UnknownStatus "wedged"))) - - it "ignores duplicate async event by source_event_id" $ \storeHandle -> do - Right () <- - Store.runStoreIO storeHandle $ - initializeRegisteredReadModel counterReadModel initializeCounterReadModelTable - let target = stream "read-model-async-idempotent" :: Stream CounterEventStream - Right (Right _) <- - Store.runStoreIO storeHandle $ - runCommand defaultRunCommandOptions counterEventStream target (Add 7) - Right recorded <- - Store.runStoreIO storeHandle $ - Store.readStreamForward (StreamName "read-model-async-idempotent") (StreamVersion 0) 10 - event <- case Vector.toList recorded of - [onlyEvent] -> pure onlyEvent - other -> expectationFailure ("expected one event, got " <> show other) *> error "unreachable" - Right outcomes <- Store.runStoreIO storeHandle $ - Store.runTransaction $ do - first <- applyAsyncProjection counterAsyncProjection event - second <- applyAsyncProjection counterAsyncProjection event - pure (first, second) - outcomes `shouldBe` (AsyncApplied, AsyncDuplicate) - queryResult <- - Store.runStoreIO storeHandle $ - runQuery Nothing counterReadModel "async-idempotent" - queryResult `shouldBe` Right (Right 7) - - it "deduplicates async projection application across transactions and reopens after pruning" $ \storeHandle -> do - Right () <- - Store.runStoreIO storeHandle $ - Store.runTransaction initializeProjectionDedupCounterTable - Right _ <- - Store.runStoreIO storeHandle $ - registerReadModel "projection-dedup-counter-model" 1 "projection-dedup-counter-v1" - let target = stream "read-model-async-dedup-window" :: Stream CounterEventStream - Right (Right _) <- - Store.runStoreIO storeHandle $ - runCommand defaultRunCommandOptions counterEventStream target (Add 7) - Right recorded <- - Store.runStoreIO storeHandle $ - Store.readStreamForward (StreamName "read-model-async-dedup-window") (StreamVersion 0) 10 - event <- case Vector.toList recorded of - [onlyEvent] -> pure onlyEvent - other -> expectationFailure ("expected one event, got " <> show other) *> error "unreachable" - let incrementingProjection = - AsyncProjection - { name = "incrementing-async-projection" - , readModelName = "projection-dedup-counter-model" - , subscriptionName = "incrementing-async-projection-sub" - , applyRecorded = \_ -> Tx.statement () incrementProjectionDedupCounterStmt - , idempotencyKey = \recordedEvent -> recordedEvent ^. #eventId - } - Right AsyncApplied <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ - applyAsyncProjection incrementingProjection event - Right AsyncDuplicate <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ - applyAsyncProjection incrementingProjection event - Right countAfterDuplicate <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ - Tx.statement () selectProjectionDedupCounterStmt - countAfterDuplicate `shouldBe` 1 - cutoff <- addUTCTime 1 <$> getCurrentTime - pruned <- Store.runStoreIO storeHandle $ pruneAsyncProjectionDedupBefore cutoff - pruned `shouldBe` Right 1 - Right AsyncApplied <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ - applyAsyncProjection incrementingProjection event - Right countAfterPrune <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ - Tx.statement () selectProjectionDedupCounterStmt - countAfterPrune `shouldBe` 2 - - it "rebuild repopulates the projection table through the supported workflow" $ \storeHandle -> do - Right () <- - Store.runStoreIO storeHandle $ - initializeRegisteredReadModel counterReadModel initializeCounterReadModelTable - let target = stream "read-model-rebuild-runbook" :: Stream CounterEventStream - Right (Right _) <- - Store.runStoreIO storeHandle $ - runCommand defaultRunCommandOptions counterEventStream target (Add 7) - Right recorded <- - Store.runStoreIO storeHandle $ - Store.readStreamForward (StreamName "read-model-rebuild-runbook") (StreamVersion 0) 10 - event <- case Vector.toList recorded of - [onlyEvent] -> pure onlyEvent - other -> expectationFailure ("expected one event, got " <> show other) *> error "unreachable" - Right AsyncApplied <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ - applyAsyncProjection counterAsyncProjection event - Right () <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ - Tx.statement - ( "counter-read-model-sub" - , globalPositionToInt (event ^. #globalPosition) - ) - upsertSubscriptionCursorStmt - beforeRebuild <- - Store.runStoreIO storeHandle $ - runQuery Nothing counterReadModel "async-idempotent" - beforeRebuild `shouldBe` Right (Right 7) - - Right rebuilding <- - Store.runStoreIO storeHandle $ - Rebuild.startRebuild - counterReadModel - [counterAsyncProjection ^. #name] - (GlobalPosition 0) - rebuilding ^. #status `shouldBe` Rebuilding - checkpointAfterReset <- - Store.runStoreIO storeHandle $ - readSubscriptionPosition "counter-read-model-sub" - checkpointAfterReset `shouldBe` Right (Just (GlobalPosition 0)) - Right AsyncApplied <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ - applyAsyncProjectionUnfenced counterAsyncProjection event - Right (Right live) <- - Store.runStoreIO storeHandle $ - Rebuild.finishRebuild - counterReadModel - [counterAsyncProjection ^. #name] - (GlobalPosition 0) - live ^. #status `shouldBe` Live - - afterRebuild <- - Store.runStoreIO storeHandle $ - runQuery Nothing counterReadModel "async-idempotent" - afterRebuild `shouldBe` Right (Right 7) - - it "keeps a non-empty-log rebuild offline when replay applies nothing" $ \storeHandle -> do - Right () <- - Store.runStoreIO storeHandle $ - initializeRegisteredReadModel counterReadModel initializeCounterReadModelTable - let target = stream "read-model-rebuild-empty-replay" :: Stream CounterEventStream - Right (Right _) <- - Store.runStoreIO storeHandle $ - runCommand defaultRunCommandOptions counterEventStream target (Add 7) - Right _ <- - Store.runStoreIO storeHandle $ - Rebuild.startRebuild - counterReadModel - [counterAsyncProjection ^. #name] - (GlobalPosition 0) - finishResult <- - Store.runStoreIO storeHandle $ - Rebuild.finishRebuild - counterReadModel - [counterAsyncProjection ^. #name] - (GlobalPosition 0) - case finishResult of - Right (Left (Rebuild.RebuildProducedNoApplies modelName headPosition)) -> do - modelName `shouldBe` "counter-read-model" - headPosition `shouldSatisfy` (> GlobalPosition 0) - other -> expectationFailure ("expected zero-apply guard, got " <> show other) - queryResult <- - Store.runStoreIO storeHandle $ - runQuery Nothing counterReadModel "async-idempotent" - queryResult - `shouldBe` Right - (Left (ReadModelNotLive "counter-read-model" Rebuilding)) - - it "fences live async application while a model is rebuilding" $ \storeHandle -> do - Right () <- - Store.runStoreIO storeHandle $ - initializeRegisteredReadModel counterReadModel initializeCounterReadModelTable - let target = stream "read-model-fenced-apply" :: Stream CounterEventStream - Right (Right _) <- - Store.runStoreIO storeHandle $ - runCommand defaultRunCommandOptions counterEventStream target (Add 7) - Right recorded <- - Store.runStoreIO storeHandle $ - Store.readStreamForward (StreamName "read-model-fenced-apply") (StreamVersion 0) 10 - event <- case Vector.toList recorded of - [onlyEvent] -> pure onlyEvent - other -> expectationFailure ("expected one event, got " <> show other) *> error "unreachable" - Right _ <- - Store.runStoreIO storeHandle $ - Rebuild.startRebuild - counterReadModel - [counterAsyncProjection ^. #name] - (GlobalPosition 0) - outcome <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ - applyAsyncProjection counterAsyncProjection event - outcome `shouldBe` Right AsyncFenced - Right dedupCount <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ - Tx.statement (counterAsyncProjection ^. #name) projectionDedupCountStmt - dedupCount `shouldBe` 0 - Right amount <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ - Tx.statement "async-idempotent" selectCounterReadModelStmt - amount `shouldBe` 0 - - it "keeps a live applier out of the rebuild window and reopens it after promotion" $ \storeHandle -> do - Right () <- - Store.runStoreIO storeHandle $ - initializeRegisteredReadModel counterReadModel initializeCounterReadModelTable - let target = stream "read-model-fence-race" :: Stream CounterEventStream - Right (Right _) <- - Store.runStoreIO storeHandle $ - runCommand defaultRunCommandOptions counterEventStream target (Add 7) - Right recorded <- - Store.runStoreIO storeHandle $ - Store.readStreamForward (StreamName "read-model-fence-race") (StreamVersion 0) 10 - event <- case Vector.toList recorded of - [onlyEvent] -> pure onlyEvent - other -> expectationFailure ("expected one event, got " <> show other) *> error "unreachable" - enterRebuildWindow <- newEmptyMVar - liveApplyResult <- newEmptyMVar - _ <- - forkIO $ do - takeMVar enterRebuildWindow - Store.runStoreIO - storeHandle - (Store.runTransaction (applyAsyncProjection counterAsyncProjection event)) - >>= putMVar liveApplyResult - Right _ <- - Store.runStoreIO storeHandle $ - Rebuild.startRebuild - counterReadModel - [counterAsyncProjection ^. #name] - (GlobalPosition 0) - putMVar enterRebuildWindow () - takeMVar liveApplyResult `shouldReturn` Right AsyncFenced - - Right AsyncApplied <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ - applyAsyncProjectionUnfenced counterAsyncProjection event - Right (Right _) <- - Store.runStoreIO storeHandle $ - Rebuild.finishRebuild - counterReadModel - [counterAsyncProjection ^. #name] - (GlobalPosition 0) - cutoff <- addUTCTime 1 <$> getCurrentTime - pruned <- Store.runStoreIO storeHandle $ pruneAsyncProjectionDedupBefore cutoff - pruned `shouldBe` Right 1 - reapplied <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ - applyAsyncProjection counterAsyncProjection event - reapplied `shouldBe` Right AsyncApplied - queryResult <- - Store.runStoreIO storeHandle $ - runQuery Nothing counterReadModel "async-idempotent" - queryResult `shouldBe` Right (Right 7) - - it "tracks rebuild state transitions" $ \storeHandle -> do - Right () <- - Store.runStoreIO storeHandle $ - registerReadModelDefinition counterReadModel - Right rebuilding <- - Store.runStoreIO storeHandle $ - Rebuild.rebuild counterReadModel - rebuilding ^. #status `shouldBe` Rebuilding - Right live <- - Store.runStoreIO storeHandle $ - Rebuild.promote counterReadModel - live ^. #status `shouldBe` Live - Right abandoned <- - Store.runStoreIO storeHandle $ - Rebuild.abandonRebuild counterReadModel - abandoned ^. #status `shouldBe` Abandoned - - it "records projection lag behind the log head" $ \storeHandle -> do - (exporter, metricsRef) <- inMemoryMetricExporter - (provider, _env) <- - createMeterProvider - emptyMaterializedResources - defaultSdkMeterProviderOptions{metricExporter = Just exporter} - meter <- getMeter provider Telemetry.keiroInstrumentationLibrary - keiroMetrics <- Telemetry.newKeiroMetrics meter - Right () <- - Store.runStoreIO storeHandle $ - initializeRegisteredReadModel counterReadModel initializeCounterReadModelTable - let target = stream "read-model-lag" :: Stream CounterEventStream - Right (Right _) <- - Store.runStoreIO storeHandle $ - runCommand defaultRunCommandOptions counterEventStream target (Add 1) - Right (Right _) <- - Store.runStoreIO storeHandle $ - runCommand defaultRunCommandOptions counterEventStream target (Add 1) - -- The subscription cursor is never advanced, so the read model is behind - -- the head by every appended event: the lag gauge records that gap. - Right () <- - Store.runStoreIO storeHandle $ - recordProjectionLag (Just keiroMetrics) counterAsyncProjection - _ <- forceFlushMeterProvider provider Nothing - exported <- readIORef metricsRef - let scalars = flattenScalarPoints exported - case lookup "keiro.projection.lag" scalars of - Just (IntNumber n) -> n `shouldSatisfy` (>= 1) - other -> expectationFailure ("expected an integer projection lag, got " <> show other) - - it "counts a position-wait timeout in the timeout counter" $ \storeHandle -> do - (exporter, metricsRef) <- inMemoryMetricExporter - (provider, _env) <- - createMeterProvider - emptyMaterializedResources - defaultSdkMeterProviderOptions{metricExporter = Just exporter} - meter <- getMeter provider Telemetry.keiroInstrumentationLibrary - keiroMetrics <- Telemetry.newKeiroMetrics meter - Right () <- - Store.runStoreIO storeHandle $ - initializeRegisteredReadModel counterReadModel initializeCounterReadModelTable - Right () <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ - Tx.statement ("counter-read-model-sub", 1) upsertSubscriptionCursorStmt - queryResult <- - Store.runStoreIO storeHandle $ - runQueryWith - (Just keiroMetrics) - (PositionWait (fastWaitOptions & #target .~ Just (GlobalPosition 5))) - counterReadModel - "timeout" - queryResult - `shouldBe` Right - (Left (ReadModelWaitTimeout "counter-read-model" (GlobalPosition 5) (GlobalPosition 1))) - _ <- forceFlushMeterProvider provider Nothing - exported <- readIORef metricsRef - let scalars = flattenScalarPoints exported - -- The single give-up bumped the counter exactly once. - lookup "keiro.projection.wait.timeouts" scalars `shouldBe` Just (IntNumber 1) - - describe "Keiro.ProcessManager" $ around (withFreshResourceStore fixture) $ do - it "advances manager state, emits a deterministic target command once, and schedules a timer" $ \(_storeHandle, StoreRunner _runner) -> do - let sourceEvent = recordedFromEventId (EventId sampleUuid) (CounterAdded 9) - result <- - _runner $ - runProcessManagerOnce defaultRunCommandOptions counterProcessManager sourceEvent (CounterAdded 9) - case result of - Right (Right pmResult) -> do - case pmResult ^. #managerResult of - PMStateAppended managerResult -> - managerResult ^. #streamVersion `shouldBe` StreamVersion 1 - other -> expectationFailure ("expected appended manager state, got " <> show other) - case pmResult ^. #commandResults of - [PMCommandAppended commandResult] -> - commandResult ^. #eventsAppended `shouldBe` 1 - other -> expectationFailure ("expected one emitted command, got " <> show other) - pmResult ^. #timersScheduled `shouldBe` 1 - other -> expectationFailure ("expected process-manager success, got " <> show other) - Right managerEvents <- - _runner $ - Store.readStreamForward (StreamName "pm:counter-order-1") (StreamVersion 0) 10 - Right targetEvents <- - _runner $ - Store.readStreamForward (StreamName "counter-target-order-1") (StreamVersion 0) 10 - Vector.length managerEvents `shouldBe` 1 - Vector.length targetEvents `shouldBe` 1 - timer <- - _runner $ - claimDueTimer dueTimerTime - case timer of - Right (Just row) -> do - row ^. #processManagerName `shouldBe` "counter-pm" - row ^. #correlationId `shouldBe` "order-1" - other -> expectationFailure ("expected scheduled timer row, got " <> show other) - - it "schedules timers when the manager command emits no events" $ \(_storeHandle, StoreRunner _runner) -> do - let sourceEvent = recordedFromEventId (EventId sampleUuid) (CounterAdded 9) - result <- - _runner $ - runProcessManagerOnce defaultRunCommandOptions timerOnlyProcessManager sourceEvent (CounterAdded 9) - case result of - Right (Right pmResult) -> do - case pmResult ^. #managerResult of - PMStateAppended managerResult -> do - managerResult ^. #streamVersion `shouldBe` StreamVersion 0 - managerResult ^. #eventsAppended `shouldBe` 0 - other -> expectationFailure ("expected no-op manager state, got " <> show other) - pmResult ^. #commandResults `shouldBe` [] - pmResult ^. #timersScheduled `shouldBe` 1 - other -> expectationFailure ("expected process-manager success, got " <> show other) - dueCount <- - _runner $ - countDueTimers dueTimerTime - dueCount `shouldBe` Right 1 - timer <- - _runner $ - claimDueTimer dueTimerTime - case timer of - Right (Just row) -> do - row ^. #processManagerName `shouldBe` "timer-only-pm" - row ^. #correlationId `shouldBe` "order-1" - other -> expectationFailure ("expected scheduled timer row, got " <> show other) - - it "treats duplicate input delivery as idempotent state and command dispatch" $ \(_storeHandle, StoreRunner _runner) -> do - let sourceEvent = recordedFromEventId (EventId sampleUuid2) (CounterAdded 4) - Right (Right _) <- - _runner $ - runProcessManagerOnce defaultRunCommandOptions counterProcessManager sourceEvent (CounterAdded 4) - duplicate <- - _runner $ - runProcessManagerOnce defaultRunCommandOptions counterProcessManager sourceEvent (CounterAdded 4) - case duplicate of - Right (Right pmResult) -> do - pmResult ^. #managerResult `shouldSatisfy` \case - PMStateDuplicate{} -> True - _ -> False - pmResult ^. #commandResults `shouldSatisfy` \case - [PMCommandDuplicate{}] -> True - _ -> False - other -> expectationFailure ("expected idempotent duplicate handling, got " <> show other) - Right managerEvents <- - _runner $ - Store.readStreamForward (StreamName "pm:counter-order-1") (StreamVersion 0) 10 - Right targetEvents <- - _runner $ - Store.readStreamForward (StreamName "counter-target-order-1") (StreamVersion 0) 10 - Vector.length managerEvents `shouldBe` 1 - Vector.length targetEvents `shouldBe` 1 - - it "replays a Kiroku dead letter freshly and deduplicates a second replay" $ \(_storeHandle, StoreRunner _runner) -> do - let subName = SubscriptionName "counter-pm-replay-fresh" - replayHandler recorded = - case decodeRecorded counterCodec recorded of - Left err -> pure (Left (Text.pack (show err))) - Right input -> do - outcome <- - runProcessManagerOnce - defaultRunCommandOptions - counterProcessManager - recorded - input - pure $ - case outcome of - Left err -> Left (Text.pack (show err)) - Right result -> Right (classifyProcessManagerReplay result) - source <- deadLetterCounterSource _storeHandle subName (CounterAdded 7) - Right listed <- _runner (listSubscriptionDeadLetters subName 0) - Vector.length listed `shouldBe` 1 - - Right firstPass <- - _runner $ - replaySubscriptionDeadLetters subName 0 replayHandler - firstPass - `shouldBe` [ ReplayOutcome - { replayGlobalPosition = source ^. #globalPosition - , replayEventId = source ^. #eventId - , replayResult = ReplayedFresh - } - ] - processManagerReplayCounts _storeHandle `shouldReturn` (1, 1) - - Right secondPass <- - _runner $ - replaySubscriptionDeadLetters subName 0 replayHandler - secondPass - `shouldBe` [ ReplayOutcome - { replayGlobalPosition = source ^. #globalPosition - , replayEventId = source ^. #eventId - , replayResult = ReplayedDuplicate - } - ] - processManagerReplayCounts _storeHandle `shouldReturn` (1, 1) - Right retained <- _runner (listSubscriptionDeadLetters subName 0) - Vector.length retained `shouldBe` 1 - - it "reports an already-processed Kiroku dead letter without appending" $ \(_storeHandle, StoreRunner _runner) -> do - let subName = SubscriptionName "counter-pm-replay-duplicate" - replayHandler recorded = - case decodeRecorded counterCodec recorded of - Left err -> pure (Left (Text.pack (show err))) - Right input -> do - outcome <- - runProcessManagerOnce - defaultRunCommandOptions - counterProcessManager - recorded - input - pure $ - case outcome of - Left err -> Left (Text.pack (show err)) - Right result -> Right (classifyProcessManagerReplay result) - source <- deadLetterCounterSource _storeHandle subName (CounterAdded 8) - Right (Right _) <- - _runner $ - runProcessManagerOnce - defaultRunCommandOptions - counterProcessManager - source - (CounterAdded 8) - countsBefore <- processManagerReplayCounts _storeHandle - - Right outcomes <- - _runner $ - replaySubscriptionDeadLetters subName 0 replayHandler - outcomes - `shouldBe` [ ReplayOutcome - { replayGlobalPosition = source ^. #globalPosition - , replayEventId = source ^. #eventId - , replayResult = ReplayedDuplicate - } - ] - processManagerReplayCounts _storeHandle `shouldReturn` countsBefore - - it "keeps multiple workflow process managers isolated by configured streams and categories" $ \(_storeHandle, StoreRunner _runner) -> do - let sourceEvent = recordedFromEventId (EventId sampleUuid) (CounterAdded 6) - fulfillmentManager = - workflowProcessManager - "fulfillment-pm" - "pm:fulfillment" - "fulfillment-target-order-1" - billingManager = - workflowProcessManager - "billing-pm" - "pm:billing" - "billing-target-order-1" - fulfillmentResult <- - _runner $ - runProcessManagerOnce defaultRunCommandOptions fulfillmentManager sourceEvent (CounterAdded 6) - billingResult <- - _runner $ - runProcessManagerOnce defaultRunCommandOptions billingManager sourceEvent (CounterAdded 6) - assertWorkflowProcessManagerAppended fulfillmentResult - assertWorkflowProcessManagerAppended billingResult - - Right fulfillmentManagerEvents <- - _runner $ - Store.readStreamForward (StreamName "pm:fulfillment-order-1") (StreamVersion 0) 10 - Right billingManagerEvents <- - _runner $ - Store.readStreamForward (StreamName "pm:billing-order-1") (StreamVersion 0) 10 - Right fulfillmentTargetEvents <- - _runner $ - Store.readStreamForward (StreamName "fulfillment-target-order-1") (StreamVersion 0) 10 - Right billingTargetEvents <- - _runner $ - Store.readStreamForward (StreamName "billing-target-order-1") (StreamVersion 0) 10 - Vector.length fulfillmentManagerEvents `shouldBe` 1 - Vector.length billingManagerEvents `shouldBe` 1 - Vector.length fulfillmentTargetEvents `shouldBe` 1 - Vector.length billingTargetEvents `shouldBe` 1 - - Right fulfillmentCategoryEvents <- - _runner $ - Store.readCategory (CategoryName "pm:fulfillment") (GlobalPosition 0) 10 - Right billingCategoryEvents <- - _runner $ - Store.readCategory (CategoryName "pm:billing") (GlobalPosition 0) 10 - Right sharedPmCategoryEvents <- - _runner $ - Store.readCategory (CategoryName "pm") (GlobalPosition 0) 10 - Right sharedPmNamespaceEvents <- - _runner $ - Store.readCategory (CategoryName "pm:") (GlobalPosition 0) 10 - Vector.length fulfillmentCategoryEvents `shouldBe` 1 - Vector.length billingCategoryEvents `shouldBe` 1 - sharedPmCategoryEvents `shouldBe` Vector.empty - sharedPmNamespaceEvents `shouldBe` Vector.empty - - it "worker finalizes AckOk through the ack handle on success" $ \(_storeHandle, StoreRunner _runner) -> do - decisionsRef <- newIORef [] - let sourceEvent = recordedFromEventId (EventId sampleUuid) (CounterAdded 9) - messages = [(sourceEvent, CounterAdded 9)] - adapter = inMemoryAdapter decisionsRef messages - Right () <- - _runner $ - runProcessManagerWorker defaultRunCommandOptions counterProcessManager adapter Just - decisions <- readIORef decisionsRef - decisions `shouldBe` [AckOk] - - it "worker halts instead of acking when a target dispatch is rejected" $ \(_storeHandle, StoreRunner _runner) -> do - decisionsRef <- newIORef [] - let sourceEvent = recordedFromEventId (EventId sampleUuid) (CounterAdded 9) - messages = [(sourceEvent, CounterAdded 9)] - adapter = inMemoryAdapter decisionsRef messages - rejectingPm = - (counterProcessManager :: ProcessManager CounterEvent (HsPred '[] CounterCommand) '[] CounterState CounterCommand CounterEvent (HsPred '[] CounterCommand) '[] CounterState CounterCommand CounterEvent) - { targetEventStream = rejectingEventStream - } - Right () <- - _runner $ - runProcessManagerWorker defaultRunCommandOptions rejectingPm adapter Just - decisions <- readIORef decisionsRef - decisions `shouldSatisfy` \case - [AckHalt (HaltFatal _)] -> True - _ -> False - Right targetEvents <- - _runner $ - Store.readStreamForward (StreamName "counter-target-order-1") (StreamVersion 0) 10 - Right managerEvents <- - _runner $ - Store.readStreamForward (StreamName "pm:counter-order-1") (StreamVersion 0) 10 - Vector.length targetEvents `shouldBe` 0 - Vector.length managerEvents `shouldBe` 1 - - it "dead-letters a rejected dispatch and continues to the next event" $ \(_storeHandle, StoreRunner _runner) -> do - (exporter, metricsRef) <- inMemoryMetricExporter - (provider, _env) <- - createMeterProvider - emptyMaterializedResources - defaultSdkMeterProviderOptions{metricExporter = Just exporter} - meter <- getMeter provider Telemetry.keiroInstrumentationLibrary - keiroMetrics <- Telemetry.newKeiroMetrics meter - decisionsRef <- newIORef [] - let first = recordedFromEventId (EventId sampleUuid) (CounterAdded 9) - second = recordedFromEventId (EventId sampleUuid2) (CounterAdded 1) - messages = [(first, CounterAdded 9), (second, CounterAdded 1)] - adapter = inMemoryAdapter decisionsRef messages - policyPm = - (counterProcessManager :: ProcessManager CounterEvent (HsPred '[] CounterCommand) '[] CounterState CounterCommand CounterEvent (HsPred '[] CounterCommand) '[] CounterState CounterCommand CounterEvent) - { targetEventStream = rejectNineEventStream - } - workerOptions = - defaultWorkerOptions - & #rejectedCommandPolicy - .~ RejectedDeadLetter - & #metrics - ?~ keiroMetrics - Right () <- - _runner $ - runProcessManagerWorkerWith workerOptions defaultRunCommandOptions policyPm adapter Just - readIORef decisionsRef `shouldReturn` [AckOk, AckOk] - Right deadLetters <- _runner (listDispatchDeadLetters "counter-pm") - case deadLetters of - [row] -> do - row ^. #dispatcherKind `shouldBe` DispatcherProcessManager - row ^. #correlationId `shouldBe` "order-1" - row ^. #sourceEventId `shouldBe` EventId sampleUuid - row ^. #emitIndex `shouldBe` 0 - row ^. #targetStreamName `shouldBe` StreamName "counter-target-order-1" - row ^. #errorClass `shouldBe` "command_rejected" - row ^. #attemptCount `shouldBe` 1 - other -> expectationFailure ("expected one rejected dispatch dead letter, got " <> show other) - Right targetEvents <- - _runner $ - Store.readStreamForward (StreamName "counter-target-order-1") (StreamVersion 0) 10 - Right managerEvents <- - _runner $ - Store.readStreamForward (StreamName "pm:counter-order-1") (StreamVersion 0) 10 - Vector.length targetEvents `shouldBe` 1 - Vector.length managerEvents `shouldBe` 2 - _ <- forceFlushMeterProvider provider Nothing - exported <- readIORef metricsRef - lookup "keiro.dispatch.deadlettered" (flattenScalarPoints exported) `shouldBe` Just (IntNumber 1) - - it "skips a rejected dispatch without writing a dead-letter row" $ \(_storeHandle, StoreRunner _runner) -> do - (exporter, metricsRef) <- inMemoryMetricExporter - (provider, _env) <- - createMeterProvider - emptyMaterializedResources - defaultSdkMeterProviderOptions{metricExporter = Just exporter} - meter <- getMeter provider Telemetry.keiroInstrumentationLibrary - keiroMetrics <- Telemetry.newKeiroMetrics meter - decisionsRef <- newIORef [] - let sourceEvent = recordedFromEventId (EventId sampleUuid) (CounterAdded 9) - adapter = inMemoryAdapter decisionsRef [(sourceEvent, CounterAdded 9)] - rejectingPm = - (counterProcessManager :: ProcessManager CounterEvent (HsPred '[] CounterCommand) '[] CounterState CounterCommand CounterEvent (HsPred '[] CounterCommand) '[] CounterState CounterCommand CounterEvent) - { targetEventStream = rejectingEventStream - } - workerOptions = - defaultWorkerOptions - & #rejectedCommandPolicy - .~ RejectedSkip - & #metrics - ?~ keiroMetrics - Right () <- - _runner $ - runProcessManagerWorkerWith workerOptions defaultRunCommandOptions rejectingPm adapter Just - readIORef decisionsRef `shouldReturn` [AckOk] - Right deadLetters <- _runner (listDispatchDeadLetters "counter-pm") - deadLetters `shouldBe` [] - _ <- forceFlushMeterProvider provider Nothing - exported <- readIORef metricsRef - lookup "keiro.dispatch.deadlettered" (flattenScalarPoints exported) `shouldBe` Just (IntNumber 1) - - it "dead-letters a manager-state rejection at emit index minus one" $ \(_storeHandle, StoreRunner _runner) -> do - decisionsRef <- newIORef [] - let sourceEvent = recordedFromEventId (EventId sampleUuid) (CounterAdded 9) - adapter = inMemoryAdapter decisionsRef [(sourceEvent, CounterAdded 9)] - rejectingManager = - (counterProcessManager :: ProcessManager CounterEvent (HsPred '[] CounterCommand) '[] CounterState CounterCommand CounterEvent (HsPred '[] CounterCommand) '[] CounterState CounterCommand CounterEvent) - { eventStream = rejectingEventStream - } - workerOptions = defaultWorkerOptions & #rejectedCommandPolicy .~ RejectedDeadLetter - Right () <- - _runner $ - runProcessManagerWorkerWith workerOptions defaultRunCommandOptions rejectingManager adapter Just - readIORef decisionsRef `shouldReturn` [AckOk] - Right deadLetters <- _runner (listDispatchDeadLetters "counter-pm") - case deadLetters of - [row] -> do - row ^. #emitIndex `shouldBe` (-1) - row ^. #targetStreamName `shouldBe` StreamName "pm:counter-order-1" - row ^. #errorClass `shouldBe` "command_rejected" - other -> expectationFailure ("expected one manager-state dead letter, got " <> show other) - Right managerEvents <- - _runner $ - Store.readStreamForward (StreamName "pm:counter-order-1") (StreamVersion 0) 10 - managerEvents `shouldBe` Vector.empty - - it "keeps rejected-dispatch dead letters idempotent on source redelivery" $ \(_storeHandle, StoreRunner _runner) -> do - decisionsRef <- newIORef [] - let sourceEvent = recordedFromEventId (EventId sampleUuid) (CounterAdded 9) - adapter = inMemoryAdapter decisionsRef [(sourceEvent, CounterAdded 9), (sourceEvent, CounterAdded 9)] - rejectingPm = - (counterProcessManager :: ProcessManager CounterEvent (HsPred '[] CounterCommand) '[] CounterState CounterCommand CounterEvent (HsPred '[] CounterCommand) '[] CounterState CounterCommand CounterEvent) - { targetEventStream = rejectingEventStream - } - workerOptions = defaultWorkerOptions & #rejectedCommandPolicy .~ RejectedDeadLetter - Right () <- - _runner $ - runProcessManagerWorkerWith workerOptions defaultRunCommandOptions rejectingPm adapter Just - readIORef decisionsRef `shouldReturn` [AckOk, AckOk] - Right deadLetters <- _runner (listDispatchDeadLetters "counter-pm") - Prelude.length deadLetters `shouldBe` 1 - - it "records dispatch failures through worker metrics" $ \(_storeHandle, StoreRunner _runner) -> do - (exporter, metricsRef) <- inMemoryMetricExporter - (provider, _env) <- - createMeterProvider - emptyMaterializedResources - defaultSdkMeterProviderOptions{metricExporter = Just exporter} - meter <- getMeter provider Telemetry.keiroInstrumentationLibrary - keiroMetrics <- Telemetry.newKeiroMetrics meter - decisionsRef <- newIORef [] - let sourceEvent = recordedFromEventId (EventId sampleUuid) (CounterAdded 9) - messages = [(sourceEvent, CounterAdded 9)] - adapter = inMemoryAdapter decisionsRef messages - rejectingPm = - (counterProcessManager :: ProcessManager CounterEvent (HsPred '[] CounterCommand) '[] CounterState CounterCommand CounterEvent (HsPred '[] CounterCommand) '[] CounterState CounterCommand CounterEvent) - { targetEventStream = rejectingEventStream - } - workerOptions = defaultWorkerOptions & #metrics ?~ keiroMetrics - Right () <- - _runner $ - runProcessManagerWorkerWith workerOptions defaultRunCommandOptions rejectingPm adapter Just - _ <- forceFlushMeterProvider provider Nothing - exported <- readIORef metricsRef - lookup "keiro.dispatch.failed" (flattenScalarPoints exported) `shouldBe` Just (IntNumber 1) - - it "classifies transient store failures as retry and deterministic command failures as halt" $ \(_storeHandle, StoreRunner _runner) -> do - isRejectionClass CommandRejected `shouldBe` True - isRejectionClass (CommandAmbiguous [0, 1]) `shouldBe` True - isRejectionClass (EncodeFailed (NonObjectCallerMetadata Aeson.Null)) `shouldBe` False - ackForCommandError (RetryDelay 5) (StoreFailed (Store.ConnectionLost "boom")) - `shouldBe` AckRetry (RetryDelay 5) - ackForCommandError (RetryDelay 5) CommandRejected `shouldSatisfy` \case - AckHalt (HaltFatal _) -> True - _ -> False - ackForCommandError (RetryDelay 5) (CommandAmbiguous [0, 1]) `shouldSatisfy` \case - AckHalt (HaltFatal _) -> True - _ -> False - - it "worker applies poison-message policy on decode failure" $ \(_storeHandle, StoreRunner _runner) -> do - let badMessages = ["not-decodable" :: Text] - defaultDecisions <- newIORef [] - Right () <- - _runner $ - runProcessManagerWorker - defaultRunCommandOptions - counterProcessManager - (inMemoryAdapter defaultDecisions badMessages) - (const Nothing) - defaultObserved <- readIORef defaultDecisions - defaultObserved `shouldSatisfy` \case - [AckHalt (HaltFatal _)] -> True - _ -> False - - skippedRef <- newIORef [] - skipDecisions <- newIORef [] - let skipOptions = - defaultWorkerOptions - & #poisonPolicy - .~ PoisonSkip (\env -> liftIO (modifyIORef' skippedRef (<> [env ^. #payload]))) - Right () <- - _runner $ - runProcessManagerWorkerWith - skipOptions - defaultRunCommandOptions - counterProcessManager - (inMemoryAdapter skipDecisions badMessages) - (const Nothing) - readIORef skipDecisions `shouldReturn` [AckOk] - readIORef skippedRef `shouldReturn` badMessages - - deadLetterDecisions <- newIORef [] - deadLetterRef <- newIORef [] - let deadLetterOptions = - defaultWorkerOptions - & #poisonPolicy - .~ PoisonDeadLetter (\env -> liftIO (modifyIORef' deadLetterRef (<> [env ^. #payload]))) - Right () <- - _runner $ - runProcessManagerWorkerWith - deadLetterOptions - defaultRunCommandOptions - counterProcessManager - (inMemoryAdapter deadLetterDecisions badMessages) - (const Nothing) - deadLetterObserved <- readIORef deadLetterDecisions - deadLetterObserved `shouldSatisfy` \case - [AckDeadLetter (InvalidPayload _)] -> True - _ -> False - readIORef deadLetterRef `shouldReturn` badMessages - - it "folds a concurrent duplicate target dispatch to PMCommandDuplicate" $ \(_storeHandle, StoreRunner _runner) -> do - insertCount <- newIORef (0 :: Int) - let sourceEvent = recordedFromEventId (EventId sampleUuid) (CounterAdded 9) - commandId = deterministicCommandId "counter-pm" "order-1" (sourceEvent ^. #eventId) 0 - targetStreamName = StreamName "counter-target-order-1" - insertConcurrentTarget = do - callNo <- atomicModifyIORef' insertCount (\n -> (n + 1, n)) - when (callNo == 1) $ appendCounterEventWithId _storeHandle targetStreamName commandId (CounterAdded 9) - options = - defaultRunCommandOptions - & #beforeAppend - .~ insertConcurrentTarget - & #retryBackoffMicros - .~ 0 - result <- - _runner $ - runProcessManagerOnce options counterProcessManager sourceEvent (CounterAdded 9) - case result of - Right (Right pmResult) -> - pmResult ^. #commandResults `shouldSatisfy` \case - [PMCommandDuplicate duplicateId] -> duplicateId == commandId - _ -> False - other -> expectationFailure ("expected duplicate target dispatch fold, got " <> show other) - Right targetEvents <- - _runner $ - Store.readStreamForward targetStreamName (StreamVersion 0) 10 - Vector.length targetEvents `shouldBe` 1 - - it "folds a concurrent duplicate manager-state append to PMStateDuplicate" $ \(_storeHandle, StoreRunner _runner) -> do - insertCount <- newIORef (0 :: Int) - let sourceEvent = recordedFromEventId (EventId sampleUuid) (CounterAdded 9) - managerId = deterministicCommandId "counter-pm" "order-1" (sourceEvent ^. #eventId) (-1) - managerStreamName = StreamName "pm:counter-order-1" - insertConcurrentManager = do - callNo <- atomicModifyIORef' insertCount (\n -> (n + 1, n)) - when (callNo == 0) $ appendCounterEventWithId _storeHandle managerStreamName managerId (CounterAdded 9) - options = - defaultRunCommandOptions - & #beforeAppend - .~ insertConcurrentManager - & #retryBackoffMicros - .~ 0 - result <- - _runner $ - runProcessManagerOnce options counterProcessManager sourceEvent (CounterAdded 9) - case result of - Right (Right pmResult) -> do - pmResult ^. #managerResult `shouldSatisfy` \case - PMStateDuplicate duplicateId -> duplicateId == managerId - _ -> False - pmResult ^. #commandResults `shouldSatisfy` \case - [PMCommandAppended{}] -> True - _ -> False - other -> expectationFailure ("expected duplicate manager-state fold, got " <> show other) - - describe "Keiro.ProcessManager duplicate confirmation" $ around (withFreshResourceStore fixture) $ do - it "rejects a duplicate report carrying a different id" $ \(_storeHandle, StoreRunner _runner) -> do - let targetStreamName = StreamName "duplicate-confirmation-mismatch" - ourId = EventId sampleUuid - otherId = EventId sampleUuid2 - appendCounterEventWithId _storeHandle targetStreamName otherId (CounterAdded 1) - outcome <- - _runner $ - confirmBenignDuplicate - targetStreamName - ourId - (StoreFailed (Store.DuplicateEvent (Just otherId))) - outcome `shouldBe` Right False - - it "rejects a matching id that exists only in another stream" $ \(_storeHandle, StoreRunner _runner) -> do - let targetStreamName = StreamName "duplicate-confirmation-target" - otherStreamName = StreamName "duplicate-confirmation-other" - ourId = EventId sampleUuid - targetEventId = EventId sampleUuid2 - appendCounterEventWithId _storeHandle targetStreamName targetEventId (CounterAdded 1) - appendCounterEventWithId _storeHandle otherStreamName ourId (CounterAdded 1) - outcome <- - _runner $ - confirmBenignDuplicate - targetStreamName - ourId - (StoreFailed (Store.DuplicateEvent (Just ourId))) - outcome `shouldBe` Right False - - it "confirms matching and id-less duplicate reports when the id is in the target stream" $ \(_storeHandle, StoreRunner _runner) -> do - let targetStreamName = StreamName "duplicate-confirmation-present" - ourId = EventId sampleUuid - appendCounterEventWithId _storeHandle targetStreamName ourId (CounterAdded 1) - matchingOutcome <- - _runner $ - confirmBenignDuplicate - targetStreamName - ourId - (StoreFailed (Store.DuplicateEvent (Just ourId))) - missingDetailOutcome <- - _runner $ - confirmBenignDuplicate - targetStreamName - ourId - (StoreFailed (Store.DuplicateEvent Nothing)) - matchingOutcome `shouldBe` Right True - missingDetailOutcome `shouldBe` Right True - - it "rejects non-duplicate command failures" $ \(_storeHandle, StoreRunner _runner) -> do - let targetStreamName = StreamName "duplicate-confirmation-non-duplicate" - ourId = EventId sampleUuid - appendCounterEventWithId _storeHandle targetStreamName ourId (CounterAdded 1) - outcome <- - _runner $ - confirmBenignDuplicate - targetStreamName - ourId - (StoreFailed (Store.ConnectionLost "boom")) - outcome `shouldBe` Right False - - describe "Keiro.ProcessManager snapshots" $ around (withFreshResourceStore fixture) $ do - it "writes a snapshot of the manager state stream after the policy threshold" $ \(_storeHandle, StoreRunner _runner) -> do - -- Two distinct source events, both correlating to "order-1", drive the one - -- manager instance to manager-stream version 2, which Every 2 snapshots. - let sourceA = recordedFromEventId (EventId sampleUuid) (CounterAdded 2) - sourceB = recordedFromEventId (EventId sampleUuid2) (CounterAdded 3) - Right (Right _) <- - _runner $ - runProcessManagerOnce defaultRunCommandOptions pmSnapshotProcessManager sourceA (CounterAdded 2) - Right (Right _) <- - _runner $ - runProcessManagerOnce defaultRunCommandOptions pmSnapshotProcessManager sourceB (CounterAdded 3) - Right managerEvents <- - _runner $ - Store.readStreamForward (StreamName "pm:counter-snap-order-1") (StreamVersion 0) 10 - Vector.length managerEvents `shouldBe` 2 - Right snapshotVersion <- - _runner $ - Store.runTransaction $ - Tx.statement "pm:counter-snap-order-1" snapshotVersionForStreamStmt - snapshotVersion `shouldBe` Just (StreamVersion 2) - - it "hydrates the manager from its snapshot and replays only the tail" $ \(_storeHandle, StoreRunner _runner) -> do - -- After the threshold snapshot exists, a third reaction should land on top of - -- the snapshot at version 3 rather than replaying from version 0. - let sourceA = recordedFromEventId (EventId sampleUuid) (CounterAdded 2) - sourceB = recordedFromEventId (EventId sampleUuid2) (CounterAdded 3) - sourceC = recordedFromEventId (EventId sampleUuid3) (CounterAdded 4) - Right (Right _) <- - _runner $ - runProcessManagerOnce defaultRunCommandOptions pmSnapshotProcessManager sourceA (CounterAdded 2) - Right (Right _) <- - _runner $ - runProcessManagerOnce defaultRunCommandOptions pmSnapshotProcessManager sourceB (CounterAdded 3) - -- Confirm the snapshot is present before the tail-replay reaction. - Right snapshotVersion <- - _runner $ - Store.runTransaction $ - Tx.statement "pm:counter-snap-order-1" snapshotVersionForStreamStmt - snapshotVersion `shouldBe` Just (StreamVersion 2) - result <- - _runner $ - runProcessManagerOnce defaultRunCommandOptions pmSnapshotProcessManager sourceC (CounterAdded 4) - case result of - Right (Right pmResult) -> - case pmResult ^. #managerResult of - PMStateAppended managerResult -> - managerResult ^. #streamVersion `shouldBe` StreamVersion 3 - other -> expectationFailure ("expected appended manager state, got " <> show other) - other -> expectationFailure ("expected snapshot-assisted PM reaction, got " <> show other) - - describe "Keiro.Router" $ around (withFreshResourceStore fixture) $ do - it "encodes colon-bearing and non-ASCII id components without collisions" $ \(_storeHandle, StoreRunner _runner) -> do - let sourceEventId = EventId sampleUuid - colonLeft = - deterministicRouterCommandId - "router:a" - "key" - sourceEventId - (StreamName "target") - 0 - colonRight = - deterministicRouterCommandId - "router" - "a:key" - sourceEventId - (StreamName "target") - 0 - unicodeLeft = - deterministicRouterCommandId - "router" - "key" - sourceEventId - (StreamName ("target-" <> Text.singleton '\x101')) - 0 - unicodeRight = - deterministicRouterCommandId - "router" - "key" - sourceEventId - (StreamName ("target-" <> Text.singleton '\x201')) - 0 - colonLeft `shouldNotBe` colonRight - unicodeLeft `shouldNotBe` unicodeRight - - it "resolves targets effectfully and fans out one command per target" $ \(_storeHandle, StoreRunner _runner) -> do - Right () <- - _runner $ - initializeRegisteredReadModel routerTargetsReadModel initializeRouterTargetsTable - Right () <- _runner $ - Store.runTransaction $ do - Tx.statement ("g1", "router-target-a") insertRouterTargetStmt - Tx.statement ("g1", "router-target-b") insertRouterTargetStmt - Tx.statement ("g1", "router-target-c") insertRouterTargetStmt - let sourceEvent = recordedFromEventId (EventId sampleUuid) (CounterAdded 1) - Right (RouterResult rs1) <- - _runner $ - runRouterOnce defaultRunCommandOptions demoRouter sourceEvent (RouteGroup "g1") - length rs1 `shouldBe` 3 - rs1 `shouldSatisfy` all isAppended - -- Data-dependence is load-bearing: an unseeded group resolves to no - -- targets, so the count tracks the read model, not a fixed list. - Right (RouterResult rsEmpty) <- - _runner $ - runRouterOnce defaultRunCommandOptions demoRouter sourceEvent (RouteGroup "no-such-group") - length rsEmpty `shouldBe` 0 - -- Each resolved target stream received exactly one command. - Right targetA <- - _runner $ - Store.readStreamForward (StreamName "router-target-a") (StreamVersion 0) 10 - Right targetB <- - _runner $ - Store.readStreamForward (StreamName "router-target-b") (StreamVersion 0) 10 - Right targetC <- - _runner $ - Store.readStreamForward (StreamName "router-target-c") (StreamVersion 0) 10 - Vector.length targetA `shouldBe` 1 - Vector.length targetB `shouldBe` 1 - Vector.length targetC `shouldBe` 1 - - it "reports every dispatch as a duplicate on replay, writing no new events" $ \(_storeHandle, StoreRunner _runner) -> do - Right () <- - _runner $ - initializeRegisteredReadModel routerTargetsReadModel initializeRouterTargetsTable - Right () <- _runner $ - Store.runTransaction $ do - Tx.statement ("g1", "router-target-a") insertRouterTargetStmt - Tx.statement ("g1", "router-target-b") insertRouterTargetStmt - Tx.statement ("g1", "router-target-c") insertRouterTargetStmt - let sourceEvent = recordedFromEventId (EventId sampleUuid) (CounterAdded 1) - Right (RouterResult rs1) <- - _runner $ - runRouterOnce defaultRunCommandOptions demoRouter sourceEvent (RouteGroup "g1") - rs1 `shouldSatisfy` all isAppended - Right (RouterResult rs2) <- - _runner $ - runRouterOnce defaultRunCommandOptions demoRouter sourceEvent (RouteGroup "g1") - length rs2 `shouldBe` 3 - rs2 `shouldSatisfy` all isDuplicate - -- Replay added nothing: each target stream still holds exactly one event. - Right targetA <- - _runner $ - Store.readStreamForward (StreamName "router-target-a") (StreamVersion 0) 10 - Right targetB <- - _runner $ - Store.readStreamForward (StreamName "router-target-b") (StreamVersion 0) 10 - Right targetC <- - _runner $ - Store.readStreamForward (StreamName "router-target-c") (StreamVersion 0) 10 - Vector.length targetA `shouldBe` 1 - Vector.length targetB `shouldBe` 1 - Vector.length targetC `shouldBe` 1 - - it "dedups by target identity when a redelivered resolve reorders targets after a partial dispatch" $ \(_storeHandle, StoreRunner _runner) -> do - attemptsRef <- newIORef (0 :: Int) - let sourceEvent = recordedFromEventId (EventId sampleUuid) (CounterAdded 1) - router = unstableRouter attemptsRef $ \case - 0 -> ["swap-a"] - _ -> ["swap-b", "swap-a"] - Right (RouterResult firstAttempt) <- - _runner $ - runRouterOnce defaultRunCommandOptions router sourceEvent (RouteGroup "g1") - firstAttempt `shouldSatisfy` all isAppended - Right (RouterResult secondAttempt) <- - _runner $ - runRouterOnce defaultRunCommandOptions router sourceEvent (RouteGroup "g1") - secondAttempt `shouldSatisfy` \case - [swapB, swapA] -> isAppended swapB && isDuplicate swapA - _ -> False - Right swapAEvents <- - _runner $ - Store.readStreamForward (StreamName "swap-a") (StreamVersion 0) 10 - Right swapBEvents <- - _runner $ - Store.readStreamForward (StreamName "swap-b") (StreamVersion 0) 10 - Vector.length swapAEvents `shouldBe` 1 - Vector.length swapBEvents `shouldBe` 1 - - it "dispatches a target added by resolve drift instead of misreading it as a duplicate" $ \(_storeHandle, StoreRunner _runner) -> do - attemptsRef <- newIORef (0 :: Int) - let sourceEvent = recordedFromEventId (EventId sampleUuid) (CounterAdded 1) - router = unstableRouter attemptsRef $ \case - 0 -> ["growth-a", "growth-b"] - _ -> ["growth-a", "growth-c"] - Right (RouterResult firstAttempt) <- - _runner $ - runRouterOnce defaultRunCommandOptions router sourceEvent (RouteGroup "g1") - firstAttempt `shouldSatisfy` all isAppended - Right (RouterResult secondAttempt) <- - _runner $ - runRouterOnce defaultRunCommandOptions router sourceEvent (RouteGroup "g1") - secondAttempt `shouldSatisfy` \case - [growthA, growthC] -> isDuplicate growthA && isAppended growthC - _ -> False - Right growthAEvents <- - _runner $ - Store.readStreamForward (StreamName "growth-a") (StreamVersion 0) 10 - Right growthBEvents <- - _runner $ - Store.readStreamForward (StreamName "growth-b") (StreamVersion 0) 10 - Right growthCEvents <- - _runner $ - Store.readStreamForward (StreamName "growth-c") (StreamVersion 0) 10 - Vector.length growthAEvents `shouldBe` 1 - Vector.length growthBEvents `shouldBe` 1 - Vector.length growthCEvents `shouldBe` 1 - - it "keeps full-completion order swaps idempotent" $ \(_storeHandle, StoreRunner _runner) -> do - attemptsRef <- newIORef (0 :: Int) - let sourceEvent = recordedFromEventId (EventId sampleUuid) (CounterAdded 1) - router = unstableRouter attemptsRef $ \case - 0 -> ["order-a", "order-b"] - _ -> ["order-b", "order-a"] - Right (RouterResult firstAttempt) <- - _runner $ - runRouterOnce defaultRunCommandOptions router sourceEvent (RouteGroup "g1") - firstAttempt `shouldSatisfy` all isAppended - Right (RouterResult secondAttempt) <- - _runner $ - runRouterOnce defaultRunCommandOptions router sourceEvent (RouteGroup "g1") - secondAttempt `shouldSatisfy` all isDuplicate - Right orderAEvents <- - _runner $ - Store.readStreamForward (StreamName "order-a") (StreamVersion 0) 10 - Right orderBEvents <- - _runner $ - Store.readStreamForward (StreamName "order-b") (StreamVersion 0) 10 - Vector.length orderAEvents `shouldBe` 1 - Vector.length orderBEvents `shouldBe` 1 - - it "keeps dispatches to targets dropped by a later resolve attempt" $ \(_storeHandle, StoreRunner _runner) -> do - attemptsRef <- newIORef (0 :: Int) - let sourceEvent = recordedFromEventId (EventId sampleUuid) (CounterAdded 1) - router = unstableRouter attemptsRef $ \case - 0 -> ["drop-a", "drop-b"] - _ -> ["drop-b"] - Right (RouterResult firstAttempt) <- - _runner $ - runRouterOnce defaultRunCommandOptions router sourceEvent (RouteGroup "g1") - firstAttempt `shouldSatisfy` all isAppended - Right (RouterResult secondAttempt) <- - _runner $ - runRouterOnce defaultRunCommandOptions router sourceEvent (RouteGroup "g1") - secondAttempt `shouldSatisfy` \case - [dropB] -> isDuplicate dropB - _ -> False - -- Resolve is authoritative per attempt. Across redeliveries, the - -- dispatched set is the union of each attempt's resolved targets. - Right dropAEvents <- - _runner $ - Store.readStreamForward (StreamName "drop-a") (StreamVersion 0) 10 - Right dropBEvents <- - _runner $ - Store.readStreamForward (StreamName "drop-b") (StreamVersion 0) 10 - Vector.length dropAEvents `shouldBe` 1 - Vector.length dropBEvents `shouldBe` 1 - - it "keeps repeated commands to one target distinct within a resolve batch" $ \(_storeHandle, StoreRunner _runner) -> do - attemptsRef <- newIORef (0 :: Int) - let sourceEvent = recordedFromEventId (EventId sampleUuid) (CounterAdded 1) - router = unstableRouter attemptsRef (const ["twin", "twin"]) - Right (RouterResult firstAttempt) <- - _runner $ - runRouterOnce defaultRunCommandOptions router sourceEvent (RouteGroup "g1") - firstAttempt `shouldSatisfy` all isAppended - Right twinEventsAfterFirstAttempt <- - _runner $ - Store.readStreamForward (StreamName "twin") (StreamVersion 0) 10 - Vector.length twinEventsAfterFirstAttempt `shouldBe` 2 - Right (RouterResult secondAttempt) <- - _runner $ - runRouterOnce defaultRunCommandOptions router sourceEvent (RouteGroup "g1") - secondAttempt `shouldSatisfy` all isDuplicate - Right twinEventsAfterSecondAttempt <- - _runner $ - Store.readStreamForward (StreamName "twin") (StreamVersion 0) 10 - Vector.length twinEventsAfterSecondAttempt `shouldBe` 2 - - it "drains an adapter, dispatching one command per resolved target for every message" $ \(_storeHandle, StoreRunner _runner) -> do - Right () <- - _runner $ - initializeRegisteredReadModel routerTargetsReadModel initializeRouterTargetsTable - Right () <- _runner $ - Store.runTransaction $ do - Tx.statement ("g1", "worker-a") insertRouterTargetStmt - Tx.statement ("g1", "worker-b") insertRouterTargetStmt - Tx.statement ("g2", "worker-c") insertRouterTargetStmt - decisionsRef <- newIORef [] - let sourceEvent1 = recordedFromEventId (EventId sampleUuid) (CounterAdded 1) - sourceEvent2 = recordedFromEventId (EventId sampleUuid2) (CounterAdded 1) - messages = - [ (sourceEvent1, RouteGroup "g1") - , (sourceEvent2, RouteGroup "g2") - ] - adapter = inMemoryAdapter decisionsRef messages - Right () <- - _runner $ - runRouterWorker defaultRunCommandOptions demoRouter adapter Just - decisions <- readIORef decisionsRef - decisions `shouldBe` [AckOk, AckOk] - Right wa <- - _runner $ - Store.readStreamForward (StreamName "worker-a") (StreamVersion 0) 10 - Right wb <- - _runner $ - Store.readStreamForward (StreamName "worker-b") (StreamVersion 0) 10 - Right wc <- - _runner $ - Store.readStreamForward (StreamName "worker-c") (StreamVersion 0) 10 - Vector.length wa `shouldBe` 1 - Vector.length wb `shouldBe` 1 - Vector.length wc `shouldBe` 1 - - it "finalizes AckHalt rather than AckOk when a dispatched command fails" $ \(_storeHandle, StoreRunner _runner) -> do - decisionsRef <- newIORef [] - let sourceEvent = recordedFromEventId (EventId sampleUuid) (CounterAdded 1) - messages = [(sourceEvent, RouteGroup "g1")] - adapter = inMemoryAdapter decisionsRef messages - Right () <- - _runner $ - runRouterWorker defaultRunCommandOptions failingRouter adapter Just - decisions <- readIORef decisionsRef - decisions `shouldSatisfy` \case - [AckHalt (HaltFatal _)] -> True - _ -> False - - it "dead-letters a rejected router dispatch and acknowledges the source event" $ \(_storeHandle, StoreRunner _runner) -> do - decisionsRef <- newIORef [] - let sourceEvent = recordedFromEventId (EventId sampleUuid) (CounterAdded 1) - adapter = inMemoryAdapter decisionsRef [(sourceEvent, RouteGroup "g1")] - workerOptions = defaultWorkerOptions & #rejectedCommandPolicy .~ RejectedDeadLetter - Right () <- - _runner $ - runRouterWorkerWith workerOptions defaultRunCommandOptions failingRouter adapter Just - readIORef decisionsRef `shouldReturn` [AckOk] - Right deadLetters <- _runner (listDispatchDeadLetters "failing-router") - case deadLetters of - [row] -> do - row ^. #dispatcherKind `shouldBe` DispatcherRouter - row ^. #correlationId `shouldBe` "g1" - row ^. #targetStreamName `shouldBe` StreamName "failing-target" - row ^. #errorClass `shouldBe` "command_rejected" - other -> expectationFailure ("expected one router dead letter, got " <> show other) - - it "finalizes AckRetry for a transient thrown resolver error and continues" $ \(_storeHandle, StoreRunner _runner) -> do - Right () <- - _runner $ - initializeRegisteredReadModel routerTargetsReadModel initializeRouterTargetsTable - Right () <- - _runner $ - Store.runTransaction (Tx.statement ("g2", "worker-after-retry") insertRouterTargetStmt) - decisionsRef <- newIORef [] - attemptsRef <- newIORef (0 :: Int) - let sourceEvent1 = recordedFromEventId (EventId sampleUuid) (CounterAdded 1) - sourceEvent2 = recordedFromEventId (EventId sampleUuid2) (CounterAdded 1) - messages = [(sourceEvent1, RouteGroup "g1"), (sourceEvent2, RouteGroup "g2")] - adapter = inMemoryAdapter decisionsRef messages - flakyRouter :: - (IOE :> es, Store :> es, Error Store.StoreError :> es) => - Router RouteGroup (HsPred '[] CounterCommand) '[] CounterState CounterCommand CounterEvent es - flakyRouter = - Router - { name = "flaky-router" - , key = \(RouteGroup g) -> g - , resolve = \(RouteGroup g) -> do - attempt <- liftIO (atomicModifyIORef' attemptsRef (\n -> (n + 1, n))) - if attempt == 0 - then throwError (Store.ConnectionLost "injected") - else do - result <- runQuery Nothing routerTargetsReadModel g - pure $ case result of - Right targetIds -> - [ PMCommand{target = stream targetId, command = Add 1} - | targetId <- targetIds - ] - Left _ -> [] - , targetEventStream = counterEventStream - , targetProjections = const [] - } - Right () <- - _runner $ - runRouterWorker defaultRunCommandOptions flakyRouter adapter Just - decisions <- readIORef decisionsRef - decisions `shouldSatisfy` \case - [AckRetry{}, AckOk] -> True - _ -> False - - it "finalizes AckHalt for a deterministic thrown resolver error" $ \(_storeHandle, StoreRunner _runner) -> do - decisionsRef <- newIORef [] - let sourceEvent = recordedFromEventId (EventId sampleUuid) (CounterAdded 1) - messages = [(sourceEvent, RouteGroup "g1")] - adapter = inMemoryAdapter decisionsRef messages - failingResolveRouter :: - (Error Store.StoreError :> es) => - Router RouteGroup (HsPred '[] CounterCommand) '[] CounterState CounterCommand CounterEvent es - failingResolveRouter = - Router - { name = "failing-resolve-router" - , key = \(RouteGroup g) -> g - , resolve = \_ -> throwError (Store.UnexpectedServerError "XX000" "boom") - , targetEventStream = counterEventStream - , targetProjections = const [] - } - Right () <- - _runner $ - runRouterWorker defaultRunCommandOptions failingResolveRouter adapter Just - decisions <- readIORef decisionsRef - decisions `shouldSatisfy` \case - [AckHalt (HaltFatal _)] -> True - _ -> False - - it "folds a concurrent duplicate router dispatch to PMCommandDuplicate" $ \(_storeHandle, StoreRunner _runner) -> do - Right () <- - _runner $ - initializeRegisteredReadModel routerTargetsReadModel initializeRouterTargetsTable - Right () <- - _runner $ - Store.runTransaction (Tx.statement ("g1", "router-duplicate-target") insertRouterTargetStmt) - insertCount <- newIORef (0 :: Int) - let sourceEvent = recordedFromEventId (EventId sampleUuid) (CounterAdded 1) - targetStreamName = StreamName "router-duplicate-target" - commandId = - deterministicRouterCommandId - "demo-router" - "g1" - (sourceEvent ^. #eventId) - targetStreamName - 0 - insertConcurrentTarget = do - callNo <- atomicModifyIORef' insertCount (\n -> (n + 1, n)) - when (callNo == 0) $ appendCounterEventWithId _storeHandle targetStreamName commandId (CounterAdded 1) - options = - defaultRunCommandOptions - & #beforeAppend - .~ insertConcurrentTarget - & #retryBackoffMicros - .~ 0 - result <- - _runner $ - runRouterOnce options demoRouter sourceEvent (RouteGroup "g1") - case result of - Right (RouterResult [PMCommandDuplicate duplicateId]) -> - duplicateId `shouldBe` commandId - other -> expectationFailure ("expected duplicate router dispatch fold, got " <> show other) - Right targetEvents <- - _runner $ - Store.readStreamForward targetStreamName (StreamVersion 0) 10 - Vector.length targetEvents `shouldBe` 1 - - it "dedups a pre-upgrade positional router dispatch during the transition" $ \(_storeHandle, StoreRunner _runner) -> do - Right () <- - _runner $ - initializeRegisteredReadModel routerTargetsReadModel initializeRouterTargetsTable - Right () <- - _runner $ - Store.runTransaction (Tx.statement ("g1", "transition-target") insertRouterTargetStmt) - let sourceEvent = recordedFromEventId (EventId sampleUuid) (CounterAdded 1) - legacyId = deterministicCommandId "demo-router" "g1" (sourceEvent ^. #eventId) 0 - targetStreamName = StreamName "transition-target" - appendCounterEventWithId _storeHandle targetStreamName legacyId (CounterAdded 1) - result <- - _runner $ - runRouterOnce defaultRunCommandOptions demoRouter sourceEvent (RouteGroup "g1") - case result of - Right (RouterResult [PMCommandDuplicate duplicateId]) -> - duplicateId `shouldBe` legacyId - other -> expectationFailure ("expected transition duplicate, got " <> show other) - Right targetEvents <- - _runner $ - Store.readStreamForward targetStreamName (StreamVersion 0) 10 - Vector.length targetEvents `shouldBe` 1 - - describe "Keiro.Timer" $ around (withFreshStore fixture) $ do - it "validates worker options before startup" $ \_storeHandle -> do - shouldBeRight_ (mkTimerWorkerOptions defaultTimerWorkerOptions) - mkTimerWorkerOptions (defaultTimerWorkerOptions & #maxAttempts ?~ (-1)) - `shouldBeLeft` InvalidTimerMaxAttempts (-1) - mkTimerWorkerOptions (defaultTimerWorkerOptions & #requeueStuckAfter ?~ 0) - `shouldBeLeft` InvalidTimerRequeueStuckAfter 0 - - it "claims a due timer, fires a command, and marks it complete once" $ \storeHandle -> do - Right () <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ - scheduleTimerTx counterTimerRequest - let firedEventId = EventId sampleUuid2 - workerResult <- Store.runStoreIO storeHandle $ - runTimerWorker Nothing dueTimerTime $ \_ -> do - fired <- - runCommand - (defaultRunCommandOptions & #eventIds .~ [firedEventId]) - counterEventStream - (stream "timer-target") - (Add 11) - case fired of - Right _ -> pure (Just firedEventId) - Left err -> liftIO (expectationFailure ("expected timer command to fire, got " <> show err)) *> pure Nothing - case workerResult of - Right (Just timer) -> - timer ^. #status `shouldBe` Firing - other -> expectationFailure ("expected fired timer, got " <> show other) - secondWorkerResult <- - Store.runStoreIO storeHandle $ - runTimerWorker Nothing dueTimerTime (\_ -> pure (Just firedEventId)) - secondWorkerResult `shouldBe` Right Nothing - Right targetEvents <- - Store.runStoreIO storeHandle $ - Store.readStreamForward (StreamName "timer-target") (StreamVersion 0) 10 - fmap (^. #eventId) (Vector.toList targetEvents) `shouldBe` [firedEventId] - - it "records timer backlog, fire lag, attempts, and stuck count" $ \storeHandle -> do - (exporter, metricsRef) <- inMemoryMetricExporter - (provider, _env) <- - createMeterProvider - emptyMaterializedResources - defaultSdkMeterProviderOptions{metricExporter = Just exporter} - meter <- getMeter provider Telemetry.keiroInstrumentationLibrary - keiroMetrics <- Telemetry.newKeiroMetrics meter - Right () <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ - scheduleTimerTx counterTimerRequest - let firedEventId = EventId sampleUuid2 - workerResult <- - Store.runStoreIO storeHandle $ - runTimerWorker (Just keiroMetrics) dueTimerTime (\_ -> pure (Just firedEventId)) - case workerResult of - Right (Just _) -> pure () - other -> expectationFailure ("expected a fired timer, got " <> show other) - _ <- forceFlushMeterProvider provider Nothing - exported <- readIORef metricsRef - let scalars = flattenScalarPoints exported - hists = flattenHistogramPoints exported - -- One scheduled+due row at the start of the pass: backlog gauge holds 1. - lookup "keiro.timer.backlog" scalars `shouldBe` Just (IntNumber 1) - -- Nothing was stranded in 'firing' before this pass: stuck gauge holds 0. - lookup "keiro.timer.stuck" scalars `shouldBe` Just (IntNumber 0) - -- The claimed timer was due exactly at 'now' and is on its first attempt: - -- one fire.lag observation of 0 ms and one attempts observation of 1. - [(c, s) | (n, c, s) <- hists, n == "keiro.timer.fire.lag"] `shouldBe` [(1, 0.0)] - [(c, s) | (n, c, s) <- hists, n == "keiro.timer.attempts"] `shouldBe` [(1, 1.0)] - - it "finds a firing timer with findStuckTimers and requeues it for re-firing" $ \storeHandle -> do - Right () <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ - scheduleTimerTx counterTimerRequest - -- Strand it in Firing by claiming without firing. - claimed <- Store.runStoreIO storeHandle $ claimDueTimer dueTimerTime - case claimed of - Right (Just timer) -> timer ^. #status `shouldBe` Firing - other -> expectationFailure ("expected a claimed timer, got " <> show other) - -- It surfaces as stuck under the permissive filter. - Right stuck <- - Store.runStoreIO storeHandle $ - findStuckTimers dueTimerTime anyStuckTimer - fmap (^. #timerId) stuck `shouldBe` [counterTimerRequest ^. #timerId] - -- A bound it does not meet (only one attempt) excludes it. - Right unmatched <- - Store.runStoreIO storeHandle $ - findStuckTimers dueTimerTime (StuckTimerFilter Nothing (Just 5)) - unmatched `shouldBe` [] - -- Requeue is idempotent: True the first time, False once it is scheduled. - requeued <- - Store.runStoreIO storeHandle $ - requeueStuckTimer (counterTimerRequest ^. #timerId) - requeued `shouldBe` Right True - requeuedAgain <- - Store.runStoreIO storeHandle $ - requeueStuckTimer (counterTimerRequest ^. #timerId) - requeuedAgain `shouldBe` Right False - -- The ordinary loop re-claims and fires it exactly once. - let firedEventId = EventId sampleUuid2 - workerResult <- Store.runStoreIO storeHandle $ - runTimerWorker Nothing dueTimerTime $ \_ -> do - fired <- - runCommand - (defaultRunCommandOptions & #eventIds .~ [firedEventId]) - counterEventStream - (stream "timer-target") - (Add 7) - case fired of - Right _ -> pure (Just firedEventId) - Left err -> liftIO (expectationFailure ("expected timer command to fire, got " <> show err)) *> pure Nothing - case workerResult of - Right (Just timer) -> - timer ^. #status `shouldBe` Firing - other -> expectationFailure ("expected re-fired timer, got " <> show other) - secondWorkerResult <- - Store.runStoreIO storeHandle $ - runTimerWorker Nothing dueTimerTime (\_ -> pure (Just firedEventId)) - secondWorkerResult `shouldBe` Right Nothing - Right targetEvents <- - Store.runStoreIO storeHandle $ - Store.readStreamForward (StreamName "timer-target") (StreamVersion 0) 10 - fmap (^. #eventId) (Vector.toList targetEvents) `shouldBe` [firedEventId] - - it "re-fires a timer stranded by a crashed worker" $ \storeHandle -> do - Right () <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ - scheduleTimerTx counterTimerRequest - Right (Just claimed) <- Store.runStoreIO storeHandle $ claimDueTimer dueTimerTime - claimed ^. #status `shouldBe` Firing - realNow <- getCurrentTime - firedRef <- newIORef [] - let futureNow = addUTCTime 400 realNow - firedEventId = EventId sampleUuid2 - workerResult <- - Store.runStoreIO storeHandle $ - runTimerWorker Nothing futureNow $ \timer -> do - liftIO (modifyIORef' firedRef (<> [timer ^. #timerId])) - pure (Just firedEventId) - case workerResult of - Right (Just timer) -> timer ^. #timerId `shouldBe` counterTimerRequest ^. #timerId - other -> expectationFailure ("expected stale timer to be requeued and claimed, got " <> show other) - firedTimers <- readIORef firedRef - firedTimers `shouldBe` [counterTimerRequest ^. #timerId] - Right statusRow <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ - Tx.statement sampleUuid timerStatusAndErrorStmt - statusRow `shouldBe` Just ("fired", Nothing) - secondWorkerResult <- - Store.runStoreIO storeHandle $ - runTimerWorker Nothing futureNow (\_ -> pure (Just firedEventId)) - secondWorkerResult `shouldBe` Right Nothing - - it "does not requeue a fresh firing row" $ \storeHandle -> do - Right () <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ - scheduleTimerTx counterTimerRequest - Right (Just _) <- Store.runStoreIO storeHandle $ claimDueTimer dueTimerTime - realNow <- getCurrentTime - firedRef <- newIORef False - workerResult <- - Store.runStoreIO storeHandle $ - runTimerWorker Nothing realNow $ \_ -> do - liftIO (writeIORef firedRef True) - pure (Just (EventId sampleUuid2)) - workerResult `shouldBe` Right Nothing - didFire <- readIORef firedRef - didFire `shouldBe` False - Right statusRow <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ - Tx.statement sampleUuid timerStatusAndErrorStmt - statusRow `shouldBe` Just ("firing", Nothing) - - it "requeueStuckAfter = Nothing preserves a stranded firing row" $ \storeHandle -> do - Right () <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ - scheduleTimerTx counterTimerRequest - Right (Just _) <- Store.runStoreIO storeHandle $ claimDueTimer dueTimerTime - realNow <- getCurrentTime - firedRef <- newIORef False - let opts = defaultTimerWorkerOptions & #requeueStuckAfter .~ Nothing - workerResult <- - Store.runStoreIO storeHandle $ - runTimerWorkerWith Nothing opts (addUTCTime 400 realNow) $ \_ -> do - liftIO (writeIORef firedRef True) - pure (Just (EventId sampleUuid2)) - workerResult `shouldBe` Right Nothing - didFire <- readIORef firedRef - didFire `shouldBe` False - Right statusRow <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ - Tx.statement sampleUuid timerStatusAndErrorStmt - statusRow `shouldBe` Just ("firing", Nothing) - - it "does not claim a cancelled timer" $ \storeHandle -> do - Right () <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ - scheduleTimerTx counterTimerRequest - cancelled <- - Store.runStoreIO storeHandle $ - cancelTimer (counterTimerRequest ^. #timerId) - cancelled `shouldBe` Right True - claimed <- Store.runStoreIO storeHandle $ claimDueTimer dueTimerTime - claimed `shouldBe` Right Nothing - cancelledAgain <- - Store.runStoreIO storeHandle $ - cancelTimer (counterTimerRequest ^. #timerId) - cancelledAgain `shouldBe` Right False - - it "dead-letters a timer that exceeds the attempt ceiling and never reclaims it" $ \storeHandle -> do - Right () <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ - scheduleTimerTx counterTimerRequest - firedRef <- newIORef False - let firedEventId = EventId sampleUuid2 - -- maxAttempts = Just 0: the first claim sets attempts = 1 > 0, so the - -- worker dead-letters instead of firing. - result <- Store.runStoreIO storeHandle $ - runTimerWorkerWith Nothing (defaultTimerWorkerOptions & #maxAttempts .~ Just 0) dueTimerTime $ \_ -> do - liftIO (writeIORef firedRef True) - pure (Just firedEventId) - case result of - Right (Just timer) -> - timer ^. #status `shouldBe` Firing - other -> expectationFailure ("expected a claimed timer, got " <> show other) - -- The fire action never ran. - didFire <- readIORef firedRef - didFire `shouldBe` False - -- The row landed in 'dead' with the expected reason in last_error. - Right statusRow <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ - Tx.statement sampleUuid timerStatusAndErrorStmt - statusRow `shouldBe` Just ("dead", Just "timer exceeded attempt ceiling of 0") - -- A dead row is never re-claimed. - secondWorkerResult <- - Store.runStoreIO storeHandle $ - runTimerWorker Nothing dueTimerTime (\_ -> pure (Just firedEventId)) - secondWorkerResult `shouldBe` Right Nothing - - it "markTimerFired does not resurrect a dead timer" $ \storeHandle -> do - Right () <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ - scheduleTimerTx counterTimerRequest - Right (Just _) <- Store.runStoreIO storeHandle $ claimDueTimer dueTimerTime - deadened <- - Store.runStoreIO storeHandle $ - deadLetterTimer (counterTimerRequest ^. #timerId) "operator dead-letter" - deadened `shouldBe` Right True - marked <- - Store.runStoreIO storeHandle $ - markTimerFired (counterTimerRequest ^. #timerId) (EventId sampleUuid2) - marked `shouldBe` Right False - Right statusRow <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ - Tx.statement sampleUuid timerStatusAndErrorStmt - statusRow `shouldBe` Just ("dead", Just "operator dead-letter") - - it "records a row stranded in Firing in the stuck gauge" $ \storeHandle -> do - (exporter, metricsRef) <- inMemoryMetricExporter - (provider, _env) <- - createMeterProvider - emptyMaterializedResources - defaultSdkMeterProviderOptions{metricExporter = Just exporter} - meter <- getMeter provider Telemetry.keiroInstrumentationLibrary - keiroMetrics <- Telemetry.newKeiroMetrics meter - Right () <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ - scheduleTimerTx counterTimerRequest - -- Strand it in Firing by claiming without firing (a crashed worker). - Right (Just _) <- Store.runStoreIO storeHandle $ claimDueTimer dueTimerTime - -- A later pass finds nothing scheduled and due, but sees the stranded row. - workerResult <- - Store.runStoreIO storeHandle $ - runTimerWorker (Just keiroMetrics) dueTimerTime (\_ -> pure Nothing) - workerResult `shouldBe` Right Nothing - _ <- forceFlushMeterProvider provider Nothing - exported <- readIORef metricsRef - let scalars = flattenScalarPoints exported - -- The one firing row is counted as stuck. - lookup "keiro.timer.stuck" scalars `shouldBe` Just (IntNumber 1) - -- It is not 'scheduled', so it does not show up as backlog. - lookup "keiro.timer.backlog" scalars `shouldBe` Just (IntNumber 0) - - describe "Keiro.Outbox.Kafka" $ do - it "converts an outbox row to a Kafka producer record" $ do - let envelope = sampleIntegrationEnvelope - row = sampleOutboxRow envelope - record = OutboxKafka.outboxRowToKafkaRecord row - record ^. #topic `shouldBe` envelope ^. #destination - record ^. #key `shouldBe` Just "order-123" - record ^. #payload `shouldBe` envelope ^. #payloadBytes - -- Headers include identity fields and content type. - let headers = record ^. #headers - messageIdHeader = Prelude.lookup "keiro-message-id" headers - messageIdHeader `shouldBe` Just "018f0f18-17aa-7000-8000-0000000000aa" - - it "drops the partition key when the envelope has no key" $ do - let envelope = sampleIntegrationEnvelope & #key .~ Nothing - record = OutboxKafka.integrationEventToKafkaRecord envelope - record ^. #key `shouldBe` Nothing - - describe "Keiro.Outbox" $ around (withFreshStore fixture) $ do - it "validates publisher options before startup" $ \_storeHandle -> do - shouldBeRight_ (mkOutboxPublishOptions defaultPublishOptions) - mkOutboxPublishOptions (defaultPublishOptions & #batchSize .~ 0) - `shouldBeLeft` InvalidOutboxBatchSize 0 - mkOutboxPublishOptions (defaultPublishOptions & #maxAttempts .~ 0) - `shouldBeLeft` InvalidOutboxMaxAttempts 0 - mkOutboxPublishOptions (defaultPublishOptions & #publishingTimeout .~ 0) - `shouldBeLeft` InvalidOutboxPublishingTimeout 0 - mkOutboxPublishOptions (defaultPublishOptions & #backoff .~ ConstantBackoff (-1)) - `shouldBeLeft` InvalidConstantBackoff (-1) - mkOutboxPublishOptions - ( defaultPublishOptions - & #backoff - .~ ExponentialBackoff - ExponentialBackoffOptions - { initial = 0 - , maxDelay = 1 - , multiplier = 2 - } - ) - `shouldBeLeft` InvalidExponentialBackoffInitial 0 - mkOutboxPublishOptions - ( defaultPublishOptions - & #backoff - .~ ExponentialBackoff - ExponentialBackoffOptions - { initial = 1 - , maxDelay = 10 - , multiplier = 0.5 - } - ) - `shouldBeLeft` InvalidExponentialBackoffMultiplier 0.5 - mkOutboxPublishOptions - ( defaultPublishOptions - & #backoff - .~ ExponentialBackoff - ExponentialBackoffOptions - { initial = 5 - , maxDelay = 4 - , multiplier = 2 - } - ) - `shouldBeLeft` InvalidExponentialBackoffMaxDelay 5 4 - - it "enqueues and looks up an outbox row" $ \storeHandle -> do - let envelope = sampleIntegrationEnvelope - oid = OutboxId outboxUuid1 - Right () <- - Store.runStoreIO storeHandle $ - Store.runTransaction (enqueueIntegrationEventTx oid envelope) - lookedUp <- Store.runStoreIO storeHandle (lookupOutbox oid) - case lookedUp of - Right (Just row) -> do - row ^. #outboxId `shouldBe` oid - row ^. #status `shouldBe` OutboxPending - row ^. #attemptCount `shouldBe` 0 - row ^. #event . #messageId `shouldBe` envelope ^. #messageId - row ^. #event . #destination `shouldBe` envelope ^. #destination - row ^. #event . #payloadBytes `shouldBe` envelope ^. #payloadBytes - other -> expectationFailure ("expected enqueued row, got " <> show other) - - it "claims a pending row, transitions it to publishing, and increments attempt count" $ \storeHandle -> do - let oid = OutboxId outboxUuid1 - Right () <- - Store.runStoreIO storeHandle $ - Store.runTransaction (enqueueIntegrationEventTx oid sampleIntegrationEnvelope) - now <- getCurrentTime - Right rows <- Store.runStoreIO storeHandle (claimOutboxBatch PerKeyHeadOfLine 10 now) - case rows of - [row] -> do - row ^. #outboxId `shouldBe` oid - row ^. #status `shouldBe` OutboxPublishing - row ^. #attemptCount `shouldBe` 1 - other -> expectationFailure ("expected one claimed row, got " <> show other) - - it "claims contiguous per-key runs in one pass" $ \storeHandle -> do - let keyedRows = - [ (outboxIdFromOrdinal 1, sampleIntegrationEnvelope & #messageId .~ "run-a1" & #key .~ Just "A") - , (outboxIdFromOrdinal 2, sampleIntegrationEnvelope & #messageId .~ "run-a2" & #key .~ Just "A") - , (outboxIdFromOrdinal 3, sampleIntegrationEnvelope & #messageId .~ "run-a3" & #key .~ Just "A") - , (outboxIdFromOrdinal 4, sampleIntegrationEnvelope & #messageId .~ "run-a4" & #key .~ Just "A") - , (outboxIdFromOrdinal 5, sampleIntegrationEnvelope & #messageId .~ "run-a5" & #key .~ Just "A") - , (outboxIdFromOrdinal 6, sampleIntegrationEnvelope & #messageId .~ "run-b1" & #key .~ Just "B") - , (outboxIdFromOrdinal 7, sampleIntegrationEnvelope & #messageId .~ "run-b2" & #key .~ Just "B") - , (outboxIdFromOrdinal 8, sampleIntegrationEnvelope & #messageId .~ "run-b3" & #key .~ Just "B") - ] - Right () <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ - traverse_ (uncurry enqueueIntegrationEventTx) keyedRows - now <- getCurrentTime - Right rows <- Store.runStoreIO storeHandle (claimOutboxBatch PerKeyHeadOfLine 10 now) - fmap (^. #outboxId) rows `shouldBe` fmap fst keyedRows - fmap (^. #attemptCount) rows `shouldBe` replicate 8 1 - - it "does not let a backoff head starve other keys" $ \storeHandle -> do - let a1Id = outboxIdFromOrdinal 1 - a2Id = outboxIdFromOrdinal 2 - b1Id = outboxIdFromOrdinal 3 - b2Id = outboxIdFromOrdinal 4 - rows = - [ (a1Id, sampleIntegrationEnvelope & #messageId .~ "backoff-a1" & #key .~ Just "A") - , (a2Id, sampleIntegrationEnvelope & #messageId .~ "backoff-a2" & #key .~ Just "A") - , (b1Id, sampleIntegrationEnvelope & #messageId .~ "backoff-b1" & #key .~ Just "B") - , (b2Id, sampleIntegrationEnvelope & #messageId .~ "backoff-b2" & #key .~ Just "B") - ] - failA1 row - | row ^. #outboxId == a1Id = pure (PublishFailed "wait") - | otherwise = pure PublishSucceeded - opts = - defaultPublishOptions - & #batchSize - .~ 1 - & #backoff - .~ ConstantBackoff 3600 - Right () <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ - traverse_ (uncurry enqueueIntegrationEventTx) rows - Right failedPass <- Store.runStoreIO storeHandle (publishClaimedOutbox (perRow failA1) opts Nothing) - failedPass ^. #retried `shouldBe` 1 - now <- getCurrentTime - Right claimed <- Store.runStoreIO storeHandle (claimOutboxBatch PerKeyHeadOfLine 10 now) - fmap (^. #outboxId) claimed `shouldBe` [b1Id, b2Id] - Right (Just a2Row) <- Store.runStoreIO storeHandle (lookupOutbox a2Id) - a2Row ^. #status `shouldBe` OutboxPending - - it "claims contiguous per-source runs in one pass" $ \storeHandle -> do - let rows = - [ (outboxIdFromOrdinal 1, sampleIntegrationEnvelope & #messageId .~ "source-a1" & #key .~ Just "A") - , (outboxIdFromOrdinal 2, sampleIntegrationEnvelope & #messageId .~ "source-b1" & #key .~ Just "B") - , (outboxIdFromOrdinal 3, sampleIntegrationEnvelope & #messageId .~ "source-a2" & #key .~ Just "A") - , (outboxIdFromOrdinal 4, sampleIntegrationEnvelope & #messageId .~ "source-b2" & #key .~ Just "B") - ] - Right () <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ - traverse_ (uncurry enqueueIntegrationEventTx) rows - now <- getCurrentTime - Right claimed <- Store.runStoreIO storeHandle (claimOutboxBatch PerSourceStream 10 now) - fmap (^. #outboxId) claimed `shouldBe` fmap fst rows - - it "claims null-keyed rows freely alongside keyed runs" $ \storeHandle -> do - let rows = - [ (outboxIdFromOrdinal 1, sampleIntegrationEnvelope & #messageId .~ "null-1" & #key .~ Nothing) - , (outboxIdFromOrdinal 2, sampleIntegrationEnvelope & #messageId .~ "keyed-1" & #key .~ Just "A") - , (outboxIdFromOrdinal 3, sampleIntegrationEnvelope & #messageId .~ "null-2" & #key .~ Nothing) - , (outboxIdFromOrdinal 4, sampleIntegrationEnvelope & #messageId .~ "keyed-2" & #key .~ Just "A") - ] - Right () <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ - traverse_ (uncurry enqueueIntegrationEventTx) rows - now <- getCurrentTime - Right claimed <- Store.runStoreIO storeHandle (claimOutboxBatch PerKeyHeadOfLine 10 now) - fmap (^. #outboxId) claimed `shouldBe` fmap fst rows - - it "does not claim a tail while the previous run is still publishing" $ \storeHandle -> do - let rows = - [ (outboxIdFromOrdinal 1, sampleIntegrationEnvelope & #messageId .~ "publishing-a1" & #key .~ Just "A") - , (outboxIdFromOrdinal 2, sampleIntegrationEnvelope & #messageId .~ "publishing-a2" & #key .~ Just "A") - , (outboxIdFromOrdinal 3, sampleIntegrationEnvelope & #messageId .~ "publishing-a3" & #key .~ Just "A") - ] - Right () <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ - traverse_ (uncurry enqueueIntegrationEventTx) rows - now <- getCurrentTime - Right firstClaim <- Store.runStoreIO storeHandle (claimOutboxBatch PerKeyHeadOfLine 10 now) - fmap (^. #outboxId) firstClaim `shouldBe` fmap fst rows - Right secondClaim <- Store.runStoreIO storeHandle (claimOutboxBatch PerKeyHeadOfLine 10 now) - secondClaim `shouldBe` [] - - it "marks a claimed row as sent with published_at set" $ \storeHandle -> do - let oid = OutboxId outboxUuid1 - Right () <- - Store.runStoreIO storeHandle $ - Store.runTransaction (enqueueIntegrationEventTx oid sampleIntegrationEnvelope) - now <- getCurrentTime - Right [_] <- Store.runStoreIO storeHandle (claimOutboxBatch PerKeyHeadOfLine 10 now) - Right True <- Store.runStoreIO storeHandle (markOutboxSent oid now) - Right (Just row) <- Store.runStoreIO storeHandle (lookupOutbox oid) - row ^. #status `shouldBe` OutboxSent - row ^. #publishedAt `shouldSatisfy` isJust - row ^. #lastError `shouldBe` Nothing - - it "reclaims a row stranded in publishing by a crashed worker through maintenance" $ \storeHandle -> do - let oid = OutboxId outboxUuid1 - Right () <- - Store.runStoreIO storeHandle $ - Store.runTransaction (enqueueIntegrationEventTx oid sampleIntegrationEnvelope) - now <- getCurrentTime - let pastNow = addUTCTime (-3600) now - Right [_] <- Store.runStoreIO storeHandle (claimOutboxBatch PerKeyHeadOfLine 10 now) - Right () <- Store.runStoreIO storeHandle (backdateOutboxUpdatedAt oid pastNow) - Right (Just stranded) <- Store.runStoreIO storeHandle (lookupOutbox oid) - stranded ^. #status `shouldBe` OutboxPublishing - publishedRef <- newIORef (0 :: Int) - let publish _ = do - liftIO (modifyIORef' publishedRef (+ 1)) - pure PublishSucceeded - Right noPublish <- Store.runStoreIO storeHandle (publishClaimedOutbox (perRow publish) defaultPublishOptions Nothing) - noPublish ^. #claimed `shouldBe` 0 - Right (Just stillStranded) <- Store.runStoreIO storeHandle (lookupOutbox oid) - stillStranded ^. #status `shouldBe` OutboxPublishing - Right maintenance <- Store.runStoreIO storeHandle (outboxMaintenancePass defaultMaintenanceOptions Nothing) - maintenance ^. #requeued `shouldBe` 1 - maintenance ^. #deadLettered `shouldBe` 0 - Right summary <- Store.runStoreIO storeHandle (publishClaimedOutbox (perRow publish) defaultPublishOptions Nothing) - summary ^. #published `shouldBe` 1 - published <- readIORef publishedRef - published `shouldBe` 1 - Right (Just row) <- Store.runStoreIO storeHandle (lookupOutbox oid) - row ^. #status `shouldBe` OutboxSent - - it "head-of-line traffic unwedges after reclaim" $ \storeHandle -> do - let firstId = OutboxId outboxUuid1 - secondId = OutboxId outboxUuid2 - first = sampleIntegrationEnvelope & #messageId .~ "stuck-first" & #key .~ Just "same-key" - second = sampleIntegrationEnvelope & #messageId .~ "stuck-second" & #key .~ Just "same-key" - Right () <- - Store.runStoreIO storeHandle $ - Store.runTransaction (enqueueIntegrationEventTx firstId first) - Right () <- - Store.runStoreIO storeHandle $ - Store.runTransaction (enqueueIntegrationEventTx secondId second) - now <- getCurrentTime - let pastNow = addUTCTime (-3600) now - Right [claimedFirst] <- Store.runStoreIO storeHandle (claimOutboxBatch PerKeyHeadOfLine 1 now) - claimedFirst ^. #outboxId `shouldBe` firstId - Right () <- Store.runStoreIO storeHandle (backdateOutboxUpdatedAt firstId pastNow) - publishedRef <- newIORef [] - let publish row = do - liftIO (modifyIORef' publishedRef (<> [row ^. #outboxId])) - pure PublishSucceeded - Right maintenance <- Store.runStoreIO storeHandle (outboxMaintenancePass defaultMaintenanceOptions Nothing) - maintenance ^. #requeued `shouldBe` 1 - Right firstPass <- Store.runStoreIO storeHandle (publishClaimedOutbox (perRow publish) defaultPublishOptions Nothing) - firstPass ^. #published `shouldBe` 2 - Right secondPass <- Store.runStoreIO storeHandle (publishClaimedOutbox (perRow publish) defaultPublishOptions Nothing) - secondPass ^. #published `shouldBe` 0 - published <- readIORef publishedRef - published `shouldBe` [firstId, secondId] - Right (Just secondRow) <- Store.runStoreIO storeHandle (lookupOutbox secondId) - secondRow ^. #status `shouldBe` OutboxSent - - it "does not reclaim a recently claimed row" $ \storeHandle -> do - let oid = OutboxId outboxUuid1 - Right () <- - Store.runStoreIO storeHandle $ - Store.runTransaction (enqueueIntegrationEventTx oid sampleIntegrationEnvelope) - now <- getCurrentTime - Right [_] <- Store.runStoreIO storeHandle (claimOutboxBatch PerKeyHeadOfLine 10 now) - publishedRef <- newIORef (0 :: Int) - let publish _ = do - liftIO (modifyIORef' publishedRef (+ 1)) - pure PublishSucceeded - Right summary <- Store.runStoreIO storeHandle (publishClaimedOutbox (perRow publish) defaultPublishOptions Nothing) - summary ^. #claimed `shouldBe` 0 - published <- readIORef publishedRef - published `shouldBe` 0 - Right (Just row) <- Store.runStoreIO storeHandle (lookupOutbox oid) - row ^. #status `shouldBe` OutboxPublishing - - it "a throwing batch publish callback fails every row in that publish call" $ \storeHandle -> do - let throwId = OutboxId outboxUuid1 - okId = OutboxId outboxUuid2 - throwEvent = sampleIntegrationEnvelope & #messageId .~ "throwing-publish" & #key .~ Just "throw-key" - okEvent = sampleIntegrationEnvelope & #messageId .~ "ok-after-throw" & #key .~ Just "ok-key" - Right () <- - Store.runStoreIO storeHandle $ - Store.runTransaction (enqueueIntegrationEventTx throwId throwEvent) - Right () <- - Store.runStoreIO storeHandle $ - Store.runTransaction (enqueueIntegrationEventTx okId okEvent) - let publish row - | row ^. #outboxId == throwId = liftIO (throwIO (userError "kafka exploded")) - | otherwise = pure PublishSucceeded - Right summary <- - Store.runStoreIO storeHandle $ - publishClaimedOutbox (perRow publish) (defaultPublishOptions & #backoff .~ ConstantBackoff 0) Nothing - summary ^. #retried `shouldBe` 2 - summary ^. #published `shouldBe` 0 - Right (Just throwRow) <- Store.runStoreIO storeHandle (lookupOutbox throwId) - throwRow ^. #status `shouldBe` OutboxFailed - throwRow ^. #lastError `shouldSatisfy` maybe False (Text.isInfixOf "kafka exploded") - Right (Just okRow) <- Store.runStoreIO storeHandle (lookupOutbox okId) - okRow ^. #status `shouldBe` OutboxFailed - okRow ^. #lastError `shouldSatisfy` maybe False (Text.isInfixOf "kafka exploded") - - it "a row that exhausts attempts while crash-looping is dead-lettered by maintenance" $ \storeHandle -> do - let oid = OutboxId outboxUuid1 - opts = defaultMaintenanceOptions & #maxAttempts .~ 1 - Right () <- - Store.runStoreIO storeHandle $ - Store.runTransaction (enqueueIntegrationEventTx oid sampleIntegrationEnvelope) - now <- getCurrentTime - let pastNow = addUTCTime (-3600) now - Right [_] <- Store.runStoreIO storeHandle (claimOutboxBatch PerKeyHeadOfLine 10 now) - Right () <- Store.runStoreIO storeHandle (backdateOutboxUpdatedAt oid pastNow) - Right summary <- Store.runStoreIO storeHandle (outboxMaintenancePass opts Nothing) - summary ^. #requeued `shouldBe` 0 - summary ^. #deadLettered `shouldBe` 1 - Right (Just row) <- Store.runStoreIO storeHandle (lookupOutbox oid) - row ^. #status `shouldBe` OutboxDead - - it "markOutboxSent does not resurrect a dead row" $ \storeHandle -> do - let oid = OutboxId outboxUuid1 - opts = defaultPublishOptions & #maxAttempts .~ 1 & #backoff .~ ConstantBackoff 0 - Right () <- - Store.runStoreIO storeHandle $ - Store.runTransaction (enqueueIntegrationEventTx oid sampleIntegrationEnvelope) - let publish _ = pure (PublishFailed "boom") - Right _ <- Store.runStoreIO storeHandle (publishClaimedOutbox (perRow publish) opts Nothing) - now <- getCurrentTime - Right marked <- Store.runStoreIO storeHandle (markOutboxSent oid now) - marked `shouldBe` False - Right (Just row) <- Store.runStoreIO storeHandle (lookupOutbox oid) - row ^. #status `shouldBe` OutboxDead - - it "publishClaimedOutbox marks success and records failures with last_error" $ \storeHandle -> do - let okId = OutboxId outboxUuid1 - failId = OutboxId outboxUuid2 - okEvent = sampleIntegrationEnvelope - failEvent = - sampleIntegrationEnvelope - & #messageId - .~ "msg-fail-1" - & #key - .~ Just "order-789" - Right () <- - Store.runStoreIO storeHandle $ - Store.runTransaction (enqueueIntegrationEventTx okId okEvent) - Right () <- - Store.runStoreIO storeHandle $ - Store.runTransaction (enqueueIntegrationEventTx failId failEvent) - let publish row - | row ^. #outboxId == okId = pure PublishSucceeded - | otherwise = pure (PublishFailed "broker unreachable") - Right summary <- - Store.runStoreIO storeHandle (publishClaimedOutbox (perRow publish) defaultPublishOptions Nothing) - summary ^. #claimed `shouldBe` 2 - summary ^. #published `shouldBe` 1 - summary ^. #retried `shouldBe` 1 - summary ^. #dead `shouldBe` 0 - Right (Just okRow) <- Store.runStoreIO storeHandle (lookupOutbox okId) - okRow ^. #status `shouldBe` OutboxSent - Right (Just failRow) <- Store.runStoreIO storeHandle (lookupOutbox failId) - failRow ^. #status `shouldBe` OutboxFailed - failRow ^. #lastError `shouldBe` Just "broker unreachable" - - it "publishClaimedOutbox hands a same-key run to one batch publish call" $ \storeHandle -> do - let rows = - [ (outboxIdFromOrdinal (fromIntegral i), sampleIntegrationEnvelope & #messageId .~ ("batch-ok-" <> Text.pack (show i)) & #key .~ Just "batch-key") - | i <- [1 .. 10 :: Int] - ] - Right () <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ - traverse_ (uncurry enqueueIntegrationEventTx) rows - invocationRef <- newIORef (0 :: Int) - let publish claimed = do - liftIO (modifyIORef' invocationRef (+ 1)) - pure [(row ^. #outboxId, PublishSucceeded) | row <- claimed] - Right summary <- Store.runStoreIO storeHandle (publishClaimedOutbox publish defaultPublishOptions Nothing) - summary ^. #claimed `shouldBe` 10 - summary ^. #published `shouldBe` 10 - invocations <- readIORef invocationRef - invocations `shouldBe` 1 - for_ (fmap fst rows) $ \oid -> do - Right (Just row) <- Store.runStoreIO storeHandle (lookupOutbox oid) - row ^. #status `shouldBe` OutboxSent - - it "publishClaimedOutbox skips the same-key suffix after a mid-run failure" $ \storeHandle -> do - let row1Id = outboxIdFromOrdinal 1 - row2Id = outboxIdFromOrdinal 2 - row3Id = outboxIdFromOrdinal 3 - row4Id = outboxIdFromOrdinal 4 - row5Id = outboxIdFromOrdinal 5 - ids = [row1Id, row2Id, row3Id, row4Id, row5Id] - rows = - [ (oid, sampleIntegrationEnvelope & #messageId .~ ("batch-fail-" <> Text.pack (show i)) & #key .~ Just "batch-fail-key") - | (i, oid) <- zip [1 .. 5 :: Int] ids - ] - publish claimed = - pure - [ ( row ^. #outboxId - , if row ^. #outboxId == row3Id - then PublishFailed "pivot failed" - else PublishSucceeded - ) - | row <- claimed - ] - Right () <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ - traverse_ (uncurry enqueueIntegrationEventTx) rows - Right summary <- - Store.runStoreIO storeHandle $ - publishClaimedOutbox publish (defaultPublishOptions & #backoff .~ ConstantBackoff 0) Nothing - summary ^. #published `shouldBe` 2 - summary ^. #retried `shouldBe` 3 - Right (Just row1) <- Store.runStoreIO storeHandle (lookupOutbox row1Id) - Right (Just row2) <- Store.runStoreIO storeHandle (lookupOutbox row2Id) - Right (Just row3) <- Store.runStoreIO storeHandle (lookupOutbox row3Id) - Right (Just row4) <- Store.runStoreIO storeHandle (lookupOutbox row4Id) - Right (Just row5) <- Store.runStoreIO storeHandle (lookupOutbox row5Id) - row1 ^. #status `shouldBe` OutboxSent - row2 ^. #status `shouldBe` OutboxSent - row3 ^. #status `shouldBe` OutboxFailed - row3 ^. #attemptCount `shouldBe` 1 - row3 ^. #lastError `shouldBe` Just "pivot failed" - row4 ^. #status `shouldBe` OutboxFailed - row4 ^. #attemptCount `shouldBe` 0 - row4 ^. #lastError `shouldBe` Just "skipped: earlier record for the same key failed" - row5 ^. #status `shouldBe` OutboxFailed - row5 ^. #attemptCount `shouldBe` 0 - - it "PerSourceStream keeps one source's failure from skipping another source's rows" $ \storeHandle -> do - let rowA1 = outboxIdFromOrdinal 1 - rowB1 = outboxIdFromOrdinal 2 - rowA2 = outboxIdFromOrdinal 3 - rowB2 = outboxIdFromOrdinal 4 - mkRow oid src msgId = - (oid, sampleIntegrationEnvelope & #messageId .~ msgId & #source .~ src & #key .~ Nothing) - rows = - [ mkRow rowA1 "per-source-a" "ps-a1" - , mkRow rowB1 "per-source-b" "ps-b1" - , mkRow rowA2 "per-source-a" "ps-a2" - , mkRow rowB2 "per-source-b" "ps-b2" - ] - publish claimed = - pure - [ ( row ^. #outboxId - , if row ^. #outboxId == rowA2 - then PublishFailed "source-a pivot failed" - else PublishSucceeded - ) - | row <- claimed - ] - Right () <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ - traverse_ (uncurry enqueueIntegrationEventTx) rows - Right summary <- - Store.runStoreIO storeHandle $ - publishClaimedOutbox publish (defaultPublishOptions & #orderingPolicy .~ PerSourceStream & #backoff .~ ConstantBackoff 0) Nothing - summary ^. #claimed `shouldBe` 4 - summary ^. #published `shouldBe` 3 - summary ^. #retried `shouldBe` 1 - Right (Just a1) <- Store.runStoreIO storeHandle (lookupOutbox rowA1) - Right (Just a2) <- Store.runStoreIO storeHandle (lookupOutbox rowA2) - Right (Just b1) <- Store.runStoreIO storeHandle (lookupOutbox rowB1) - Right (Just b2) <- Store.runStoreIO storeHandle (lookupOutbox rowB2) - a1 ^. #status `shouldBe` OutboxSent - a2 ^. #status `shouldBe` OutboxFailed - a2 ^. #attemptCount `shouldBe` 1 - a2 ^. #lastError `shouldBe` Just "source-a pivot failed" - b1 ^. #status `shouldBe` OutboxSent - b2 ^. #status `shouldBe` OutboxSent - - it "a late failure mark does not clobber a row that already reached a terminal state" $ \storeHandle -> do - let oid = OutboxId outboxUuid1 - Right () <- - Store.runStoreIO storeHandle $ - Store.runTransaction (enqueueIntegrationEventTx oid sampleIntegrationEnvelope) - now <- getCurrentTime - Right [_] <- Store.runStoreIO storeHandle (claimOutboxBatch PerKeyHeadOfLine 10 now) - Right True <- Store.runStoreIO storeHandle (markOutboxSent oid now) - Right _ <- - Store.runStoreIO storeHandle $ - Store.runTransaction (markOutboxFailedTx oid "late failure from a timed-out worker" 5 60 now) - Right (Just row) <- Store.runStoreIO storeHandle (lookupOutbox oid) - row ^. #status `shouldBe` OutboxSent - row ^. #lastError `shouldBe` Nothing - - it "claims nothing while another transaction holds an uncommitted claim on a key's head" $ \storeHandle -> do - let headId = outboxIdFromOrdinal 1 - tailId = outboxIdFromOrdinal 2 - rows = - [ (headId, sampleIntegrationEnvelope & #messageId .~ "claim-race-1" & #key .~ Just "claim-race-key") - , (tailId, sampleIntegrationEnvelope & #messageId .~ "claim-race-2" & #key .~ Just "claim-race-key") - ] - OutboxId headUuid = headId - holdClaimSql = - TE.encodeUtf8 $ - "UPDATE keiro.keiro_outbox SET status = 'publishing', attempt_count = attempt_count + 1, updated_at = now() WHERE outbox_id = '" - <> UUID.toText headUuid - <> "'" - Right () <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ - traverse_ (uncurry enqueueIntegrationEventTx) rows - holderDone <- newEmptyMVar - _ <- forkIO $ do - holder <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ do - Tx.sql holdClaimSql - Tx.sql "SELECT pg_sleep(2)" - putMVar holderDone holder - -- Let the holder acquire its uncommitted row lock, then race a claim. - threadDelay 500000 - now <- getCurrentTime - Right claimed <- Store.runStoreIO storeHandle (claimOutboxBatch PerKeyHeadOfLine 10 now) - fmap (^. #outboxId) claimed `shouldBe` [] - Right () <- takeMVar holderDone - pure () - - it "StopTheLine publishes singleton batches and skips the unattempted suffix" $ \storeHandle -> do - let row1Id = outboxIdFromOrdinal 1 - row2Id = outboxIdFromOrdinal 2 - row3Id = outboxIdFromOrdinal 3 - row4Id = outboxIdFromOrdinal 4 - ids = [row1Id, row2Id, row3Id, row4Id] - rows = - [ (oid, sampleIntegrationEnvelope & #messageId .~ ("stop-line-" <> Text.pack (show i)) & #key .~ Just "stop-key") - | (i, oid) <- zip [1 .. 4 :: Int] ids - ] - publishRef = fmap (^. #outboxId) - publish claimed = - pure - [ ( row ^. #outboxId - , if row ^. #outboxId == row2Id - then PublishFailed "stop here" - else PublishSucceeded - ) - | row <- claimed - ] - Right () <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ - traverse_ (uncurry enqueueIntegrationEventTx) rows - seenRef <- newIORef [] - let trackedPublish claimed = do - liftIO (modifyIORef' seenRef (<> publishRef claimed)) - publish claimed - opts = defaultPublishOptions & #orderingPolicy .~ StopTheLine & #backoff .~ ConstantBackoff 0 - Right summary <- Store.runStoreIO storeHandle (publishClaimedOutbox trackedPublish opts Nothing) - summary ^. #published `shouldBe` 1 - summary ^. #retried `shouldBe` 3 - summary ^. #haltedOn `shouldBe` Just row2Id - seen <- readIORef seenRef - seen `shouldBe` take 2 ids - Right (Just row3) <- Store.runStoreIO storeHandle (lookupOutbox row3Id) - Right (Just row4) <- Store.runStoreIO storeHandle (lookupOutbox row4Id) - row3 ^. #status `shouldBe` OutboxFailed - row3 ^. #attemptCount `shouldBe` 0 - row4 ^. #status `shouldBe` OutboxFailed - row4 ^. #attemptCount `shouldBe` 0 - - it "publishClaimedOutbox treats a missing batch outcome as a failed row" $ \storeHandle -> do - let okId = outboxIdFromOrdinal 1 - missingId = outboxIdFromOrdinal 2 - okEvent = sampleIntegrationEnvelope & #messageId .~ "missing-outcome-ok" & #key .~ Just "ok-key" - missingEvent = sampleIntegrationEnvelope & #messageId .~ "missing-outcome-fail" & #key .~ Just "missing-key" - publish claimed = - pure - [ (row ^. #outboxId, PublishSucceeded) - | row <- claimed - , row ^. #outboxId == okId - ] - Right () <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ do - enqueueIntegrationEventTx okId okEvent - enqueueIntegrationEventTx missingId missingEvent - Right summary <- Store.runStoreIO storeHandle (publishClaimedOutbox publish defaultPublishOptions Nothing) - summary ^. #published `shouldBe` 1 - summary ^. #retried `shouldBe` 1 - Right (Just missingRow) <- Store.runStoreIO storeHandle (lookupOutbox missingId) - missingRow ^. #status `shouldBe` OutboxFailed - missingRow ^. #lastError `shouldBe` Just "publisher returned no outcome" - - it "auto-dead-letters a row after maxAttempts consecutive failures" $ \storeHandle -> do - let oid = OutboxId outboxUuid1 - event = sampleIntegrationEnvelope & #key .~ Nothing - opts = - defaultPublishOptions - & #batchSize - .~ 10 - & #maxAttempts - .~ 3 - & #backoff - .~ ConstantBackoff 0 - & #orderingPolicy - .~ BestEffort - Right () <- - Store.runStoreIO storeHandle $ - Store.runTransaction (enqueueIntegrationEventTx oid event) - let publish _ = pure (PublishFailed "broker exploded") - -- First two failures retain Failed status. - Right s1 <- Store.runStoreIO storeHandle (publishClaimedOutbox (perRow publish) opts Nothing) - s1 ^. #retried `shouldBe` 1 - s1 ^. #dead `shouldBe` 0 - Right s2 <- Store.runStoreIO storeHandle (publishClaimedOutbox (perRow publish) opts Nothing) - s2 ^. #retried `shouldBe` 1 - s2 ^. #dead `shouldBe` 0 - -- Third failure crosses the threshold. - Right s3 <- Store.runStoreIO storeHandle (publishClaimedOutbox (perRow publish) opts Nothing) - s3 ^. #dead `shouldBe` 1 - Right (Just row) <- Store.runStoreIO storeHandle (lookupOutbox oid) - row ^. #status `shouldBe` OutboxDead - -- A dead row is not claimable. - now <- getCurrentTime - Right reclaimed <- Store.runStoreIO storeHandle (claimOutboxBatch BestEffort 10 now) - reclaimed `shouldBe` [] - - it "garbageCollectSent deletes only old sent rows" $ \storeHandle -> do - let oldSentId = OutboxId outboxUuid1 - recentSentId = OutboxId outboxUuid2 - failedId = OutboxId outboxUuid3 - deadId = OutboxId outboxUuid4 - base = sampleIntegrationEnvelope & #key .~ Nothing - Right () <- - Store.runStoreIO storeHandle $ - Store.runTransaction (enqueueIntegrationEventTx oldSentId (base & #messageId .~ "gc-old-sent")) - Right () <- - Store.runStoreIO storeHandle $ - Store.runTransaction (enqueueIntegrationEventTx recentSentId (base & #messageId .~ "gc-recent-sent")) - Right () <- - Store.runStoreIO storeHandle $ - Store.runTransaction (enqueueIntegrationEventTx failedId (base & #messageId .~ "gc-failed")) - let firstPass row - | row ^. #outboxId == failedId = pure (PublishFailed "keep failed") - | otherwise = pure PublishSucceeded - firstPassOpts = - defaultPublishOptions - & #batchSize - .~ 10 - & #orderingPolicy - .~ BestEffort - & #backoff - .~ ConstantBackoff 3600 - Right _ <- Store.runStoreIO storeHandle (publishClaimedOutbox (perRow firstPass) firstPassOpts Nothing) - Right () <- - Store.runStoreIO storeHandle $ - Store.runTransaction (enqueueIntegrationEventTx deadId (base & #messageId .~ "gc-dead")) - let deadPass row - | row ^. #outboxId == deadId = pure (PublishFailed "keep dead") - | otherwise = pure PublishSucceeded - deadPassOpts = - defaultPublishOptions - & #batchSize - .~ 10 - & #maxAttempts - .~ 1 - & #orderingPolicy - .~ BestEffort - Right _ <- Store.runStoreIO storeHandle (publishClaimedOutbox (perRow deadPass) deadPassOpts Nothing) - now <- getCurrentTime - Right () <- Store.runStoreIO storeHandle (backdateOutboxPublishedAt oldSentId (addUTCTime (-3600) now)) - Right deleted <- Store.runStoreIO storeHandle (garbageCollectSent 300 now) - deleted `shouldBe` 1 - Right oldRow <- Store.runStoreIO storeHandle (lookupOutbox oldSentId) - oldRow `shouldBe` Nothing - Right (Just recentRow) <- Store.runStoreIO storeHandle (lookupOutbox recentSentId) - recentRow ^. #status `shouldBe` OutboxSent - Right (Just failedRow) <- Store.runStoreIO storeHandle (lookupOutbox failedId) - failedRow ^. #status `shouldBe` OutboxFailed - Right (Just deadRow) <- Store.runStoreIO storeHandle (lookupOutbox deadId) - deadRow ^. #status `shouldBe` OutboxDead - - it "enforces per-key head-of-line blocking and unblocks once the predecessor reaches a terminal state" $ \storeHandle -> do - let a1Id = OutboxId outboxUuid1 - a2Id = OutboxId outboxUuid2 - b1Id = OutboxId outboxUuid3 - a1 = sampleIntegrationEnvelope & #messageId .~ "a1" & #key .~ Just "k1" - a2 = sampleIntegrationEnvelope & #messageId .~ "a2" & #key .~ Just "k1" - b1 = sampleIntegrationEnvelope & #messageId .~ "b1" & #key .~ Just "k2" - -- Insert in created_at order (a1 first, then a2, then b1). - Right () <- - Store.runStoreIO storeHandle $ - Store.runTransaction (enqueueIntegrationEventTx a1Id a1) - Right () <- - Store.runStoreIO storeHandle $ - Store.runTransaction (enqueueIntegrationEventTx a2Id a2) - Right () <- - Store.runStoreIO storeHandle $ - Store.runTransaction (enqueueIntegrationEventTx b1Id b1) - claimed <- newIORef [] - let publish row = do - liftIO (atomicModifyIORef' claimed (\xs -> ((row ^. #outboxId) : xs, ()))) - if row ^. #outboxId == a1Id - then pure (PublishFailed "broker hiccup") - else pure PublishSucceeded - -- First pass: with a one-row batch, a1 fails and both later rows remain pending. - let firstPassOpts = - defaultPublishOptions - & #batchSize - .~ 1 - & #backoff - .~ ConstantBackoff 0 - Right summary1 <- - Store.runStoreIO storeHandle (publishClaimedOutbox (perRow publish) firstPassOpts Nothing) - summary1 ^. #claimed `shouldBe` 1 - claimedIds <- readIORef claimed - claimedIds `shouldSatisfy` (a2Id `notElem`) - claimedIds `shouldSatisfy` (a1Id `elem`) - claimedIds `shouldSatisfy` (b1Id `notElem`) - Right (Just a1Row) <- Store.runStoreIO storeHandle (lookupOutbox a1Id) - a1Row ^. #status `shouldBe` OutboxFailed - Right (Just b1Row) <- Store.runStoreIO storeHandle (lookupOutbox b1Id) - b1Row ^. #status `shouldBe` OutboxPending - Right (Just a2Row) <- Store.runStoreIO storeHandle (lookupOutbox a2Id) - a2Row ^. #status `shouldBe` OutboxPending - -- Drive a1 to terminal sent state so a2 can move. One pass claims a1 - -- (now that next_attempt_at has passed). A second pass claims a2, - -- which becomes head-of-line once a1 reaches `sent`. - writeIORef claimed [] - let publishOk row = do - liftIO (atomicModifyIORef' claimed (\xs -> ((row ^. #outboxId) : xs, ()))) - pure PublishSucceeded - retryOpts = - defaultPublishOptions - & #batchSize - .~ 1 - & #backoff - .~ ConstantBackoff 0 - Right _ <- Store.runStoreIO storeHandle (publishClaimedOutbox (perRow publishOk) retryOpts Nothing) - Right _ <- Store.runStoreIO storeHandle (publishClaimedOutbox (perRow publishOk) retryOpts Nothing) - Right _ <- Store.runStoreIO storeHandle (publishClaimedOutbox (perRow publishOk) retryOpts Nothing) - claimedIds2 <- readIORef claimed - claimedIds2 `shouldSatisfy` (a1Id `elem`) - claimedIds2 `shouldSatisfy` (a2Id `elem`) - claimedIds2 `shouldSatisfy` (b1Id `elem`) - Right (Just a2Row') <- Store.runStoreIO storeHandle (lookupOutbox a2Id) - a2Row' ^. #status `shouldBe` OutboxSent - - it "allows null-keyed rows to publish independently" $ \storeHandle -> do - let n1 = OutboxId outboxUuid1 - n2 = OutboxId outboxUuid2 - e = sampleIntegrationEnvelope & #key .~ Nothing - Right () <- - Store.runStoreIO storeHandle $ - Store.runTransaction (enqueueIntegrationEventTx n1 (e & #messageId .~ "n1")) - Right () <- - Store.runStoreIO storeHandle $ - Store.runTransaction (enqueueIntegrationEventTx n2 (e & #messageId .~ "n2")) - let publish row - | row ^. #outboxId == n1 = pure (PublishFailed "transient") - | otherwise = pure PublishSucceeded - Right summary <- - Store.runStoreIO storeHandle $ - publishClaimedOutbox (perRow publish) (defaultPublishOptions & #backoff .~ ConstantBackoff 0) Nothing - summary ^. #claimed `shouldBe` 2 - summary ^. #published `shouldBe` 1 - summary ^. #retried `shouldBe` 1 - - it "mints message ids with the configured TypeID prefix" $ \storeHandle -> do - Right minted <- - Store.runStoreIO storeHandle (mintIntegrationEvent sampleProducer sampleDraft) - minted ^. #source `shouldBe` "ordering" - minted ^. #destination `shouldBe` "billing.orders.v1" - Text.isPrefixOf "msg_" (minted ^. #messageId) `shouldBe` True - - it "validates integration producer message id prefixes before startup" $ \_storeHandle -> do - shouldBeRight_ (mkIntegrationProducer sampleProducer) - case mkIntegrationProducer (sampleProducer & #messageIdPrefix .~ "Bad-Prefix") of - Left (InvalidMessageIdPrefix prefix reason) -> do - prefix `shouldBe` "Bad-Prefix" - reason `shouldSatisfy` (not . Text.null) - other -> expectationFailure ("expected invalid prefix, got " <> show (void other)) - - it "draftToEvent stamps source and messageId without minting" $ \_storeHandle -> do - let event = draftToEvent "ordering" "msg-fixed-1" sampleDraft - event ^. #messageId `shouldBe` "msg-fixed-1" - event ^. #source `shouldBe` "ordering" - event ^. #destination `shouldBe` "billing.orders.v1" - - it "freshOutboxId returns distinct UUIDv7 ids" $ \storeHandle -> do - Right ids <- - Store.runStoreIO storeHandle (traverse (\_ -> freshOutboxId) [1 .. 4 :: Int]) - length ids `shouldBe` 4 - length (uniqueIds ids) `shouldBe` 4 - - it "publishClaimedOutbox emits a Producer span with messaging semconv attributes" $ \storeHandle -> do - (processor, spansRef) <- inMemoryListExporter - provider <- createTracerProvider [processor] emptyTracerProviderOptions - let tracer = makeTracer provider "keiro-test" tracerOptions - okId = OutboxId outboxUuid1 - failId = OutboxId outboxUuid2 - okEvent = sampleIntegrationEnvelope - failEvent = - sampleIntegrationEnvelope - & #messageId - .~ "msg-fail-otel-1" - & #key - .~ Just "order-otel-fail" - Right () <- - Store.runStoreIO storeHandle $ - Store.runTransaction (enqueueIntegrationEventTx okId okEvent) - Right () <- - Store.runStoreIO storeHandle $ - Store.runTransaction (enqueueIntegrationEventTx failId failEvent) - let publish row - | row ^. #outboxId == okId = pure PublishSucceeded - | otherwise = pure (PublishFailed "broker unreachable") - opts = defaultPublishOptions & #tracer ?~ tracer - Right _ <- Store.runStoreIO storeHandle (publishClaimedOutbox (perRow publish) opts Nothing) - _ <- shutdownTracerProvider provider Nothing - spans <- traverse captureSpan =<< readIORef spansRef - length spans `shouldBe` 1 - case spans of - [batchSpan] -> do - csName batchSpan `shouldBe` ("send " <> (okEvent ^. #destination)) - show (csKind batchSpan) `shouldBe` "Producer" - textAttr (csAttributes batchSpan) "messaging.system" `shouldBe` Just "kafka" - textAttr (csAttributes batchSpan) "messaging.operation.type" `shouldBe` Just "publish" - textAttr (csAttributes batchSpan) "messaging.operation.name" `shouldBe` Just "send" - textAttr (csAttributes batchSpan) "messaging.destination.name" - `shouldBe` Just (okEvent ^. #destination) - textAttr (csAttributes batchSpan) "messaging.kafka.message.key" - `shouldBe` (okEvent ^. #key) - intAttr (csAttributes batchSpan) "keiro.outbox.batch.size" `shouldBe` Just 2 - textAttr (csAttributes batchSpan) "error.type" `shouldBe` Just "publish_failed" - case csStatus batchSpan of - Error msg -> msg `shouldBe` "broker unreachable" - other -> expectationFailure ("expected Error \"broker unreachable\", got " <> show other) - other -> expectationFailure ("expected one batch span, got " <> show (length other)) - - it "publishClaimedOutbox records counters and sampleOutboxBacklog records the gauge" $ \storeHandle -> do - (exporter, metricsRef) <- inMemoryMetricExporter - (provider, _env) <- - createMeterProvider - emptyMaterializedResources - defaultSdkMeterProviderOptions{metricExporter = Just exporter} - meter <- getMeter provider Telemetry.keiroInstrumentationLibrary - keiroMetrics <- Telemetry.newKeiroMetrics meter - let okId = OutboxId outboxUuid1 - failId = OutboxId outboxUuid2 - okEvent = sampleIntegrationEnvelope & #messageId .~ "metrics-ok" & #key .~ Nothing - failEvent = sampleIntegrationEnvelope & #messageId .~ "metrics-fail" & #key .~ Nothing - Right () <- - Store.runStoreIO storeHandle $ - Store.runTransaction (enqueueIntegrationEventTx okId okEvent) - Right () <- - Store.runStoreIO storeHandle $ - Store.runTransaction (enqueueIntegrationEventTx failId failEvent) - let publish row - | row ^. #outboxId == okId = pure PublishSucceeded - | otherwise = pure (PublishFailed "broker down") - retryPassOpts = - defaultPublishOptions - & #batchSize - .~ 10 - & #maxAttempts - .~ 5 - & #backoff - .~ ConstantBackoff 0 - & #orderingPolicy - .~ BestEffort - deadPassOpts = retryPassOpts & #maxAttempts .~ 1 - -- Pass 1 (maxAttempts = 5): ok publishes, the fail row retries. - Right summary1 <- - Store.runStoreIO storeHandle (publishClaimedOutbox (perRow publish) retryPassOpts (Just keiroMetrics)) - summary1 ^. #published `shouldBe` 1 - summary1 ^. #retried `shouldBe` 1 - -- Pass 2 (maxAttempts = 1): the failed row crosses the ceiling and dies. - Right summary2 <- - Store.runStoreIO storeHandle (publishClaimedOutbox (perRow publish) deadPassOpts (Just keiroMetrics)) - summary2 ^. #dead `shouldBe` 1 - -- Flush so the in-memory exporter receives the aggregates. - _ <- forceFlushMeterProvider provider Nothing - exported <- readIORef metricsRef - let scalars = flattenScalarPoints exported - -- Counters are cumulative across both passes. - lookup "keiro.outbox.published" scalars `shouldBe` Just (IntNumber 1) - lookup "keiro.outbox.retried" scalars `shouldBe` Just (IntNumber 1) - lookup "keiro.outbox.deadlettered" scalars `shouldBe` Just (IntNumber 1) - -- Publish passes no longer run the backlog COUNT(*) on the hot path. - lookup "keiro.outbox.backlog" scalars `shouldBe` Nothing - - Store.runStoreIO storeHandle (sampleOutboxBacklog (Just keiroMetrics)) `shouldReturn` Right () - _ <- forceFlushMeterProvider provider Nothing - sampled <- readIORef metricsRef - let sampledScalars = flattenScalarPoints sampled - lookup "keiro.outbox.backlog" sampledScalars `shouldBe` Just (IntNumber 0) - - describe "Keiro.Inbox" $ around (withFreshStore fixture) $ do - it "runs the handler once and records the row as completed" $ \storeHandle -> do - Right () <- - Store.runStoreIO storeHandle $ - Store.runTransaction (Tx.sql "CREATE TABLE IF NOT EXISTS inbox_test_counter (message_id TEXT PRIMARY KEY)") - let event = - sampleIntegrationEnvelope - & #messageId - .~ "inbox-msg-1" - & #source - .~ "ordering" - handler ev = - Tx.statement (ev ^. #messageId) inboxTestCounterInsertStmt - Right result1 <- - Store.runStoreIO storeHandle $ - runInboxTransaction Nothing PreferIntegrationMessageId event Nothing handler - case result1 of - Right (InboxProcessed ()) -> pure () - other -> expectationFailure ("expected InboxProcessed, got " <> show other) - Right rowCount1 <- - Store.runStoreIO storeHandle $ - Store.runTransaction (Tx.statement () inboxTestCounterCountStmt) - rowCount1 `shouldBe` 1 - Right (Just inboxRow) <- Store.runStoreIO storeHandle (lookupInbox "ordering" "inbox-msg-1") - inboxRow ^. #status `shouldBe` InboxCompleted - inboxRow ^. #completedAt `shouldSatisfy` isJust - - it "treats a redelivery with the same messageId as a duplicate" $ \storeHandle -> do - Right () <- - Store.runStoreIO storeHandle $ - Store.runTransaction (Tx.sql "CREATE TABLE IF NOT EXISTS inbox_test_counter (message_id TEXT PRIMARY KEY)") - let event = - sampleIntegrationEnvelope - & #messageId - .~ "inbox-msg-dup" - & #source - .~ "ordering" - handler ev = Tx.statement (ev ^. #messageId) inboxTestCounterInsertStmt - Right (Right (InboxProcessed ())) <- - Store.runStoreIO storeHandle $ - runInboxTransaction Nothing PreferIntegrationMessageId event Nothing handler - Right result2 <- - Store.runStoreIO storeHandle $ - runInboxTransaction Nothing PreferIntegrationMessageId event Nothing handler - result2 `shouldBe` Right InboxDuplicate - Right rowCount <- - Store.runStoreIO storeHandle $ - Store.runTransaction (Tx.statement () inboxTestCounterCountStmt) - rowCount `shouldBe` 1 - - it "records inbox counters and samples backlog separately under the in-memory exporter" $ \storeHandle -> do - (exporter, metricsRef) <- inMemoryMetricExporter - (provider, _env) <- - createMeterProvider - emptyMaterializedResources - defaultSdkMeterProviderOptions{metricExporter = Just exporter} - meter <- getMeter provider Telemetry.keiroInstrumentationLibrary - keiroMetrics <- Telemetry.newKeiroMetrics meter - Right () <- - Store.runStoreIO storeHandle $ - Store.runTransaction (Tx.sql "CREATE TABLE IF NOT EXISTS inbox_test_counter (message_id TEXT PRIMARY KEY)") - let event = sampleIntegrationEnvelope & #messageId .~ "inbox-metrics-dup" & #source .~ "ordering" - handler ev = Tx.statement (ev ^. #messageId) inboxTestCounterInsertStmt - -- First delivery runs the handler: processed. - Right (Right (InboxProcessed ())) <- - Store.runStoreIO storeHandle $ - runInboxTransaction (Just keiroMetrics) PreferIntegrationMessageId event Nothing handler - -- Second delivery of the same (source, message_id): duplicate. - Right result2 <- - Store.runStoreIO storeHandle $ - runInboxTransaction (Just keiroMetrics) PreferIntegrationMessageId event Nothing handler - result2 `shouldBe` Right InboxDuplicate - _ <- forceFlushMeterProvider provider Nothing - exported <- readIORef metricsRef - let scalars = flattenScalarPoints exported - lookup "keiro.inbox.processed" scalars `shouldBe` Just (IntNumber 1) - lookup "keiro.inbox.duplicates" scalars `shouldBe` Just (IntNumber 1) - lookup "keiro.inbox.backlog" scalars `shouldBe` Nothing - Store.runStoreIO storeHandle (sampleInboxBacklog (Just keiroMetrics)) `shouldReturn` Right () - _ <- forceFlushMeterProvider provider Nothing - sampled <- readIORef metricsRef - let sampledScalars = flattenScalarPoints sampled - lookup "keiro.inbox.backlog" sampledScalars `shouldBe` Just (IntNumber 0) - -- The handler ran exactly once (the duplicate path does not re-run it). - Right rowCount <- - Store.runStoreIO storeHandle $ - Store.runTransaction (Tx.statement () inboxTestCounterCountStmt) - rowCount `shouldBe` 1 - - it "deduplicates via PreferSourceEventIdentity even when messageId differs" $ \storeHandle -> do - Right () <- - Store.runStoreIO storeHandle $ - Store.runTransaction (Tx.sql "CREATE TABLE IF NOT EXISTS inbox_test_counter (message_id TEXT PRIMARY KEY)") - let shared = sampleIntegrationEnvelope & #source .~ "ordering" - first = shared & #messageId .~ "republish-1" - second = shared & #messageId .~ "republish-2" - handler ev = Tx.statement (ev ^. #messageId) inboxTestCounterInsertStmt - Right (Right (InboxProcessed ())) <- - Store.runStoreIO storeHandle $ - runInboxTransaction Nothing PreferSourceEventIdentity first Nothing handler - Right result2 <- - Store.runStoreIO storeHandle $ - runInboxTransaction Nothing PreferSourceEventIdentity second Nothing handler - result2 `shouldBe` Right InboxDuplicate - - it "uses KafkaDeliveryIdentity when supplied" $ \storeHandle -> do - Right () <- - Store.runStoreIO storeHandle $ - Store.runTransaction (Tx.sql "CREATE TABLE IF NOT EXISTS inbox_test_counter (message_id TEXT PRIMARY KEY)") - let event = sampleIntegrationEnvelope & #source .~ "ordering" - kafka = KafkaDeliveryRef "billing.orders.v1" 0 17 - handler ev = Tx.statement (ev ^. #messageId) inboxTestCounterInsertStmt - Right (Right (InboxProcessed ())) <- - Store.runStoreIO storeHandle $ - runInboxTransaction Nothing KafkaDeliveryIdentity event (Just kafka) handler - Right (Right InboxDuplicate) <- - Store.runStoreIO storeHandle $ - runInboxTransaction Nothing KafkaDeliveryIdentity event (Just kafka) handler - Right (Just row) <- - Store.runStoreIO storeHandle $ - lookupInbox "ordering" "billing.orders.v1:0:17" - row ^. #status `shouldBe` InboxCompleted - - it "reports DedupePolicyUnsatisfied when the envelope lacks the required field" $ \storeHandle -> do - let event = - sampleIntegrationEnvelope - & #source - .~ "ordering" - & #sourceEventId - .~ Nothing - & #sourceGlobalPosition - .~ Nothing - Right result <- - Store.runStoreIO storeHandle $ - runInboxTransaction Nothing PreferSourceEventIdentity event Nothing (\_ -> pure ()) - result `shouldBe` Left (DedupePolicyUnsatisfied PreferSourceEventIdentity) - - it "leaves no inbox row when the handler condemns the transaction" $ \storeHandle -> do - let event = - sampleIntegrationEnvelope - & #messageId - .~ "inbox-msg-rollback" - & #source - .~ "ordering" - handler _ = do - Tx.condemn - pure () - _ <- - Store.runStoreIO storeHandle $ - runInboxTransaction Nothing PreferIntegrationMessageId event Nothing handler - Right row <- Store.runStoreIO storeHandle (lookupInbox "ordering" "inbox-msg-rollback") - row `shouldBe` Nothing - - it "leaves no inbox row when the plain handler throws" $ \storeHandle -> do - let event = - sampleIntegrationEnvelope - & #messageId - .~ "inbox-msg-throw-plain" - & #source - .~ "ordering" - handler _ = (pure $! error "plain inbox handler failed") :: Tx.Transaction () - thrown <- - try $ - Store.runStoreIO storeHandle $ - runInboxTransaction Nothing PreferIntegrationMessageId event Nothing handler - case thrown of - Left (_ :: SomeException) -> pure () - Right other -> expectationFailure ("expected handler exception, got " <> show (void other)) - Right row <- Store.runStoreIO storeHandle (lookupInbox "ordering" "inbox-msg-throw-plain") - row `shouldBe` Nothing - - it "exports markFailedTx from the public inbox module and preserves explicit failure marks" $ \storeHandle -> do - let event = - sampleIntegrationEnvelope - & #messageId - .~ "inbox-msg-public-failed" - & #source - .~ "ordering" - handler _ = do - markFailedTx "ordering" "inbox-msg-public-failed" "operator failed" (event ^. #occurredAt) - pure () - Right (Right (InboxProcessed ())) <- - Store.runStoreIO storeHandle $ - runInboxTransaction Nothing PreferIntegrationMessageId event Nothing handler - Right (Just row) <- Store.runStoreIO storeHandle (lookupInbox "ordering" "inbox-msg-public-failed") - row ^. #status `shouldBe` InboxFailed - row ^. #lastError `shouldBe` Just "operator failed" - - it "a throwing handler records a failed attempt instead of looping" $ \storeHandle -> do - let event = - sampleIntegrationEnvelope - & #messageId - .~ "inbox-msg-poison-1" - & #source - .~ "ordering" - handler _ = (pure $! error "inbox exploded") :: Tx.Transaction () - Right result <- - Store.runStoreIO storeHandle $ - runInboxTransactionWithRetries Nothing 3 PreferIntegrationMessageId event Nothing handler - case result of - Right (InboxHandlerFailed err attempts) -> do - Text.isInfixOf "inbox exploded" err `shouldBe` True - attempts `shouldBe` 1 - other -> expectationFailure ("expected InboxHandlerFailed, got " <> show other) - Right (Just row) <- Store.runStoreIO storeHandle (lookupInbox "ordering" "inbox-msg-poison-1") - row ^. #status `shouldBe` InboxFailed - row ^. #attemptCount `shouldBe` 1 - row ^. #lastError `shouldSatisfy` maybe False (Text.isInfixOf "inbox exploded") - - it "a transient poison message succeeds on retry" $ \storeHandle -> do - Right () <- - Store.runStoreIO storeHandle $ - Store.runTransaction (Tx.sql "CREATE TABLE IF NOT EXISTS inbox_test_counter (message_id TEXT PRIMARY KEY)") - let event = - sampleIntegrationEnvelope - & #messageId - .~ "inbox-msg-poison-transient" - & #source - .~ "ordering" - failOnce _ = (pure $! error "temporary inbox failure") :: Tx.Transaction () - succeeding ev = Tx.statement (ev ^. #messageId) inboxTestCounterInsertStmt - Right result1 <- - Store.runStoreIO storeHandle $ - runInboxTransactionWithRetries Nothing 3 PreferIntegrationMessageId event Nothing failOnce - case result1 of - Right (InboxHandlerFailed _ 1) -> pure () - other -> expectationFailure ("expected first failed attempt, got " <> show other) - Right result2 <- - Store.runStoreIO storeHandle $ - runInboxTransactionWithRetries Nothing 3 PreferIntegrationMessageId event Nothing succeeding - result2 `shouldBe` Right (InboxProcessed ()) - Right (Just row) <- Store.runStoreIO storeHandle (lookupInbox "ordering" "inbox-msg-poison-transient") - row ^. #status `shouldBe` InboxCompleted - row ^. #attemptCount `shouldBe` 1 - Right rowCount <- - Store.runStoreIO storeHandle $ - Store.runTransaction (Tx.statement () inboxTestCounterCountStmt) - rowCount `shouldBe` 1 - - it "an unrecoverable message dead-letters at the ceiling" $ \storeHandle -> do - let event = - sampleIntegrationEnvelope - & #messageId - .~ "inbox-msg-poison-dead" - & #source - .~ "ordering" - handler _ = (pure $! error "always broken") :: Tx.Transaction () - Right result1 <- - Store.runStoreIO storeHandle $ - runInboxTransactionWithRetries Nothing 2 PreferIntegrationMessageId event Nothing handler - Right result2 <- - Store.runStoreIO storeHandle $ - runInboxTransactionWithRetries Nothing 2 PreferIntegrationMessageId event Nothing handler - Right result3 <- - Store.runStoreIO storeHandle $ - runInboxTransactionWithRetries Nothing 2 PreferIntegrationMessageId event Nothing handler - case (result1, result2, result3) of - ( Right (InboxHandlerFailed _ 1) - , Right (InboxHandlerFailed _ 2) - , Right (InboxPreviouslyFailed _) - ) -> pure () - other -> expectationFailure ("unexpected poison lifecycle: " <> show other) - Right (Just row) <- Store.runStoreIO storeHandle (lookupInbox "ordering" "inbox-msg-poison-dead") - row ^. #status `shouldBe` InboxFailed - row ^. #attemptCount `shouldBe` 2 - - it "processes a batch of distinct messages in one transaction" $ \storeHandle -> do - Right () <- - Store.runStoreIO storeHandle $ - Store.runTransaction (Tx.sql "CREATE TABLE IF NOT EXISTS inbox_test_counter (message_id TEXT PRIMARY KEY)") - let events = - [ sampleIntegrationEnvelope - & #messageId - .~ ("inbox-batch-msg-" <> Text.pack (show n)) - & #source - .~ "batch-ordering" - | n <- [1 .. 50 :: Int] - ] - handler ev = Tx.statement (ev ^. #messageId) inboxTestCounterInsertStmt - Right results <- - Store.runStoreIO storeHandle $ - runInboxTransactionBatch Nothing 3 PreferIntegrationMessageId PersistFullEnvelope ((,Nothing) <$> events) handler - results `shouldBe` replicate 50 (Right (InboxProcessed ())) - Right rowCount <- - Store.runStoreIO storeHandle $ - Store.runTransaction (Tx.statement () inboxTestCounterCountStmt) - rowCount `shouldBe` 50 - Right inboxRows <- Store.runStoreIO storeHandle (listInbox "batch-ordering") - length inboxRows `shouldBe` 50 - all ((== InboxCompleted) . (^. #status)) inboxRows `shouldBe` True - - it "deduplicates repeated messages within one batch" $ \storeHandle -> do - Right () <- - Store.runStoreIO storeHandle $ - Store.runTransaction (Tx.sql "CREATE TABLE IF NOT EXISTS inbox_test_counter (message_id TEXT PRIMARY KEY)") - let event = - sampleIntegrationEnvelope - & #messageId - .~ "inbox-batch-dup" - & #source - .~ "batch-ordering" - handler ev = Tx.statement (ev ^. #messageId) inboxTestCounterInsertStmt - Right results <- - Store.runStoreIO storeHandle $ - runInboxTransactionBatch Nothing 3 PreferIntegrationMessageId PersistFullEnvelope [(event, Nothing), (event, Nothing)] handler - results `shouldBe` [Right (InboxProcessed ()), Right InboxDuplicate] - Right rowCount <- - Store.runStoreIO storeHandle $ - Store.runTransaction (Tx.statement () inboxTestCounterCountStmt) - rowCount `shouldBe` 1 - - it "falls back per message when one batch handler throws" $ \storeHandle -> do - Right () <- - Store.runStoreIO storeHandle $ - Store.runTransaction (Tx.sql "CREATE TABLE IF NOT EXISTS inbox_test_counter (message_id TEXT PRIMARY KEY)") - let events = - [ sampleIntegrationEnvelope - & #messageId - .~ ("inbox-batch-poison-" <> Text.pack (show n)) - & #source - .~ "batch-ordering" - | n <- [1 .. 5 :: Int] - ] - handler ev - | ev ^. #messageId == "inbox-batch-poison-3" = - (pure $! error "batch poison") :: Tx.Transaction () - | otherwise = - Tx.statement (ev ^. #messageId) inboxTestCounterInsertStmt - Right results <- - Store.runStoreIO storeHandle $ - runInboxTransactionBatch Nothing 3 PreferIntegrationMessageId PersistFullEnvelope ((,Nothing) <$> events) handler - case results of - [ Right (InboxProcessed ()) - , Right (InboxProcessed ()) - , Right (InboxHandlerFailed err 1) - , Right (InboxProcessed ()) - , Right (InboxProcessed ()) - ] -> - Text.isInfixOf "batch poison" err `shouldBe` True - other -> expectationFailure ("unexpected batch fallback results: " <> show other) - Right rowCount <- - Store.runStoreIO storeHandle $ - Store.runTransaction (Tx.statement () inboxTestCounterCountStmt) - rowCount `shouldBe` 4 - Right (Just row) <- Store.runStoreIO storeHandle (lookupInbox "batch-ordering" "inbox-batch-poison-3") - row ^. #status `shouldBe` InboxFailed - row ^. #attemptCount `shouldBe` 1 - row ^. #lastError `shouldSatisfy` maybe False (Text.isInfixOf "batch poison") - - it "reports duplicates across batch calls" $ \storeHandle -> do - Right () <- - Store.runStoreIO storeHandle $ - Store.runTransaction (Tx.sql "CREATE TABLE IF NOT EXISTS inbox_test_counter (message_id TEXT PRIMARY KEY)") - let event = - sampleIntegrationEnvelope - & #messageId - .~ "inbox-batch-existing-dup" - & #source - .~ "batch-ordering" - handler ev = Tx.statement (ev ^. #messageId) inboxTestCounterInsertStmt - Right first <- - Store.runStoreIO storeHandle $ - runInboxTransactionBatch Nothing 3 PreferIntegrationMessageId PersistFullEnvelope [(event, Nothing)] handler - first `shouldBe` [Right (InboxProcessed ())] - Right second <- - Store.runStoreIO storeHandle $ - runInboxTransactionBatch Nothing 3 PreferIntegrationMessageId PersistFullEnvelope [(event, Nothing)] handler - second `shouldBe` [Right InboxDuplicate] - Right rowCount <- - Store.runStoreIO storeHandle $ - Store.runTransaction (Tx.statement () inboxTestCounterCountStmt) - rowCount `shouldBe` 1 - - it "falls back per message when one batch handler condemns the transaction" $ \storeHandle -> do - Right () <- - Store.runStoreIO storeHandle $ - Store.runTransaction (Tx.sql "CREATE TABLE IF NOT EXISTS inbox_test_counter (message_id TEXT PRIMARY KEY)") - let events = - [ sampleIntegrationEnvelope - & #messageId - .~ ("inbox-batch-condemn-" <> Text.pack (show n)) - & #source - .~ "batch-ordering" - | n <- [1 .. 3 :: Int] - ] - handler ev - | ev ^. #messageId == "inbox-batch-condemn-2" = Tx.condemn - | otherwise = Tx.statement (ev ^. #messageId) inboxTestCounterInsertStmt - Right results <- - Store.runStoreIO storeHandle $ - runInboxTransactionBatch Nothing 3 PreferIntegrationMessageId PersistFullEnvelope ((,Nothing) <$> events) handler - -- The condemned single-message retry reports processed by the - -- documented single-path contract; what matters is that the - -- innocent batch mates actually committed. - results `shouldBe` replicate 3 (Right (InboxProcessed ())) - Right rowCount <- - Store.runStoreIO storeHandle $ - Store.runTransaction (Tx.statement () inboxTestCounterCountStmt) - rowCount `shouldBe` 2 - Right (Just mate1) <- Store.runStoreIO storeHandle (lookupInbox "batch-ordering" "inbox-batch-condemn-1") - Right (Just mate3) <- Store.runStoreIO storeHandle (lookupInbox "batch-ordering" "inbox-batch-condemn-3") - mate1 ^. #status `shouldBe` InboxCompleted - mate3 ^. #status `shouldBe` InboxCompleted - Right condemned <- Store.runStoreIO storeHandle (lookupInbox "batch-ordering" "inbox-batch-condemn-2") - condemned `shouldBe` Nothing - - it "classifies a legacy processing row as InboxInProgress without running the handler" $ \storeHandle -> do - Right () <- - Store.runStoreIO storeHandle $ - Store.runTransaction (Tx.sql "CREATE TABLE IF NOT EXISTS inbox_test_counter (message_id TEXT PRIMARY KEY)") - let event = - sampleIntegrationEnvelope - & #messageId - .~ "inbox-legacy-processing" - & #source - .~ "ordering" - handler ev = Tx.statement (ev ^. #messageId) inboxTestCounterInsertStmt - Right () <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ - Tx.sql "INSERT INTO keiro.keiro_inbox (source, dedupe_key, content_type, payload_bytes, status) VALUES ('ordering', 'inbox-legacy-processing', 'application/json', ''::bytea, 'processing')" - Right result <- - Store.runStoreIO storeHandle $ - runInboxTransaction Nothing PreferIntegrationMessageId event Nothing handler - result `shouldBe` Right InboxInProgress - Right rowCount <- - Store.runStoreIO storeHandle $ - Store.runTransaction (Tx.statement () inboxTestCounterCountStmt) - rowCount `shouldBe` 0 - Right (Just row) <- Store.runStoreIO storeHandle (lookupInbox "ordering" "inbox-legacy-processing") - row ^. #status `shouldBe` InboxProcessing - - it "runs the handler once when two workers race the same dedupe key" $ \storeHandle -> do - Right () <- - Store.runStoreIO storeHandle $ - Store.runTransaction (Tx.sql "CREATE TABLE IF NOT EXISTS inbox_test_counter (message_id TEXT PRIMARY KEY)") - let event = - sampleIntegrationEnvelope - & #messageId - .~ "inbox-race-dup" - & #source - .~ "ordering" - slowHandler ev = do - Tx.statement (ev ^. #messageId) inboxTestCounterInsertStmt - Tx.sql "SELECT pg_sleep(1.5)" - fastHandler ev = Tx.statement (ev ^. #messageId) inboxTestCounterInsertStmt - firstDone <- newEmptyMVar - _ <- forkIO $ do - first <- - Store.runStoreIO storeHandle $ - runInboxTransaction Nothing PreferIntegrationMessageId event Nothing slowHandler - putMVar firstDone first - -- Let the slow worker insert its uncommitted row, then race the - -- same dedupe key: the second insert must block on the unique - -- constraint until the first commits, then classify as duplicate. - threadDelay 400000 - Right second <- - Store.runStoreIO storeHandle $ - runInboxTransaction Nothing PreferIntegrationMessageId event Nothing fastHandler - Right first <- takeMVar firstDone - first `shouldBe` Right (InboxProcessed ()) - second `shouldBe` Right InboxDuplicate - Right rowCount <- - Store.runStoreIO storeHandle $ - Store.runTransaction (Tx.statement () inboxTestCounterCountStmt) - rowCount `shouldBe` 1 - - it "can persist only dedupe columns for successful rows" $ \storeHandle -> do - let kafka = KafkaDeliveryRef "billing.orders.v1" 1 42 - event = - sampleIntegrationEnvelope - & #messageId - .~ "inbox-slim-success" - & #source - .~ "ordering" - & #payloadBytes - .~ "full success payload" - & #attributes - ?~ object ["source" Aeson..= ("slim-test" :: Text)] - handler _ = pure () - Right (Right (InboxProcessed ())) <- - Store.runStoreIO storeHandle $ - runInboxTransactionWith Nothing PersistDedupeOnly PreferIntegrationMessageId event (Just kafka) handler - Right (Just row) <- Store.runStoreIO storeHandle (lookupInbox "ordering" "inbox-slim-success") - row ^. #event . #payloadBytes `shouldBe` "" - row ^. #event . #attributes `shouldBe` Nothing - row ^. #event . #traceContext `shouldBe` Nothing - row ^. #event . #schemaReference `shouldBe` Nothing - row ^. #event . #messageId `shouldBe` "inbox-slim-success" - row ^. #event . #sourceEventId `shouldBe` event ^. #sourceEventId - row ^. #event . #sourceGlobalPosition `shouldBe` event ^. #sourceGlobalPosition - row ^. #event . #causationId `shouldBe` event ^. #causationId - row ^. #event . #correlationId `shouldBe` event ^. #correlationId - row ^. #event . #occurredAt `shouldBe` event ^. #occurredAt - row ^. #kafka `shouldBe` Just kafka - Right redelivery <- - Store.runStoreIO storeHandle $ - runInboxTransactionWith Nothing PersistDedupeOnly PreferIntegrationMessageId event (Just kafka) handler - redelivery `shouldBe` Right InboxDuplicate - - it "keeps full failed rows even when successful rows are dedupe-only" $ \storeHandle -> do - let event = - sampleIntegrationEnvelope - & #messageId - .~ "inbox-slim-failed" - & #source - .~ "ordering" - & #payloadBytes - .~ "full failed payload" - & #attributes - ?~ object ["source" Aeson..= ("failed-slim-test" :: Text)] - handler _ = (pure $! error "slim failure") :: Tx.Transaction () - Right result <- - Store.runStoreIO storeHandle $ - runInboxTransactionWithRetriesWith Nothing 3 PersistDedupeOnly PreferIntegrationMessageId event Nothing handler - case result of - Right (InboxHandlerFailed err 1) -> - Text.isInfixOf "slim failure" err `shouldBe` True - other -> expectationFailure ("expected InboxHandlerFailed, got " <> show other) - Right (Just row) <- Store.runStoreIO storeHandle (lookupInbox "ordering" "inbox-slim-failed") - row ^. #status `shouldBe` InboxFailed - row ^. #event . #payloadBytes `shouldBe` event ^. #payloadBytes - row ^. #event . #attributes `shouldBe` event ^. #attributes - row ^. #event . #traceContext `shouldBe` event ^. #traceContext - row ^. #event . #schemaReference `shouldBe` event ^. #schemaReference - - it "garbage-collects completed rows older than the retention window" $ \storeHandle -> do - let event = - sampleIntegrationEnvelope - & #messageId - .~ "inbox-msg-gc" - & #source - .~ "ordering" - handler _ = pure () - Right (Right (InboxProcessed ())) <- - Store.runStoreIO storeHandle $ - runInboxTransaction Nothing PreferIntegrationMessageId event Nothing handler - -- Backdate the row so it falls outside the retention window. - Right () <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ - Tx.sql - "UPDATE keiro.keiro_inbox SET completed_at = now() - interval '40 days' WHERE message_id = 'inbox-msg-gc'" - now <- getCurrentTime - Right deleted <- Store.runStoreIO storeHandle (garbageCollectCompleted (nominalDays 30) now) - deleted `shouldBe` 1 - Right rows <- Store.runStoreIO storeHandle (listInbox "ordering") - rows `shouldBe` [] - - describe "Keiro.Inbox.Kafka" $ do - it "reconstructs an integration event from headers and payload" $ do - let envelope = sampleIntegrationEnvelope - headers = integrationHeaders envelope - receivedAt = addUTCTime 60 (envelope ^. #occurredAt) - record = - InboxKafka.KafkaInboundRecord - { topic = "billing.orders.v1" - , partition = 2 - , offset = 113 - , key = Just "order-123" - , payload = envelope ^. #payloadBytes - , headers - , receivedAt - } - case InboxKafka.integrationEventFromKafka record of - Right (rebuilt, kafkaRef) -> do - rebuilt ^. #messageId `shouldBe` envelope ^. #messageId - rebuilt ^. #source `shouldBe` envelope ^. #source - rebuilt ^. #destination `shouldBe` envelope ^. #destination - rebuilt ^. #eventType `shouldBe` envelope ^. #eventType - rebuilt ^. #schemaVersion `shouldBe` envelope ^. #schemaVersion - rebuilt ^. #sourceEventId `shouldBe` envelope ^. #sourceEventId - rebuilt ^. #sourceGlobalPosition `shouldBe` envelope ^. #sourceGlobalPosition - rebuilt ^. #payloadBytes `shouldBe` envelope ^. #payloadBytes - rebuilt ^. #occurredAt `shouldBe` envelope ^. #occurredAt - rebuilt ^. #attributes `shouldBe` envelope ^. #attributes - kafkaRef ^. #topic `shouldBe` "billing.orders.v1" - kafkaRef ^. #partition `shouldBe` 2 - kafkaRef ^. #offset `shouldBe` 113 - Left err -> expectationFailure ("expected Right, got Left " <> show err) - - it "falls back to receivedAt when the occurredAt header is absent" $ do - let envelope = sampleIntegrationEnvelope - receivedAt = addUTCTime 60 (envelope ^. #occurredAt) - headers = filter ((/= "keiro-occurred-at") . Prelude.fst) (integrationHeaders envelope) - record = - InboxKafka.KafkaInboundRecord - { topic = "billing.orders.v1" - , partition = 2 - , offset = 113 - , key = Just "order-123" - , payload = envelope ^. #payloadBytes - , headers - , receivedAt - } - case InboxKafka.integrationEventFromKafka record of - Right (rebuilt, _) -> rebuilt ^. #occurredAt `shouldBe` receivedAt - Left err -> expectationFailure ("expected Right, got Left " <> show err) - - it "rejects malformed occurredAt headers" $ do - let envelope = sampleIntegrationEnvelope - headers = ("keiro-occurred-at", "not-a-time") : filter ((/= "keiro-occurred-at") . Prelude.fst) (integrationHeaders envelope) - record = - InboxKafka.KafkaInboundRecord - { topic = "billing.orders.v1" - , partition = 2 - , offset = 113 - , key = Just "order-123" - , payload = envelope ^. #payloadBytes - , headers - , receivedAt = envelope ^. #occurredAt - } - InboxKafka.integrationEventFromKafka record - `shouldBe` Left (InboxKafka.InvalidTimeHeader "keiro-occurred-at" "not-a-time") - - it "reports MissingHeader for an essential header" $ do - let envelope = sampleIntegrationEnvelope - headers = filter ((/= "keiro-message-id") . Prelude.fst) (integrationHeaders envelope) - record = - InboxKafka.KafkaInboundRecord - { topic = "billing.orders.v1" - , partition = 0 - , offset = 0 - , key = Nothing - , payload = envelope ^. #payloadBytes - , headers - , receivedAt = envelope ^. #occurredAt - } - InboxKafka.integrationEventFromKafka record - `shouldBe` Left (InboxKafka.MissingHeader "keiro-message-id") - - it "withConsumerSpan parents the consumer span under an upstream producer span via W3C headers" $ do - (processor, spansRef) <- inMemoryListExporter - provider <- createTracerProvider [processor] emptyTracerProviderOptions - let tracer = makeTracer provider "keiro-test" tracerOptions - -- Clear the baked-in TraceContext on the sample so the only - -- `traceparent` on the wire comes from the active producer - -- span (via `injectTraceContext`). - envelope = sampleIntegrationEnvelope & #traceContext .~ Nothing - producerRecord = OutboxKafka.integrationEventToKafkaRecord envelope - producerHeadersText <- - Telemetry.withProducerSpan (Just tracer) envelope producerRecord $ \_ -> do - let baseHeaders = - [(TE.decodeUtf8 n, TE.decodeUtf8 v) | (n, v) <- producerRecord ^. #headers] - Telemetry.injectTraceContext baseHeaders - -- Build the inbound record the consumer would receive and open the - -- consumer span around a no-op body. - now <- getCurrentTime - let inbound = - InboxKafka.KafkaInboundRecord - { topic = envelope ^. #destination - , partition = 7 - , offset = 42 - , key = envelope ^. #key - , payload = envelope ^. #payloadBytes - , headers = producerHeadersText - , receivedAt = now - } - Telemetry.withConsumerSpan (Just tracer) (Just "billing-cg") inbound (Just envelope) $ \_ -> - pure () - _ <- shutdownTracerProvider provider Nothing - spans <- traverse captureSpan =<< readIORef spansRef - length spans `shouldBe` 2 - let findByName needle = case [s | s <- spans, csName s == needle] of - (s : _) -> s - [] -> error ("no span captured with name=" <> Text.unpack needle) - producerSp = findByName ("send " <> envelope ^. #destination) - consumerSp = findByName ("process " <> envelope ^. #destination) - -- Same trace id end-to-end (cross-process parenting). - traceId (csContext producerSp) `shouldBe` traceId (csContext consumerSp) - -- Consumer's parent is the producer span. - case csParent consumerSp of - Nothing -> expectationFailure "consumer span has no parent" - Just parent -> do - parentCtx <- getSpanContext parent - spanId parentCtx `shouldBe` spanId (csContext producerSp) - -- Consumer span carries the expected attributes. - show (csKind consumerSp) `shouldBe` "Consumer" - textAttr (csAttributes consumerSp) "messaging.system" `shouldBe` Just "kafka" - textAttr (csAttributes consumerSp) "messaging.operation.type" `shouldBe` Just "process" - textAttr (csAttributes consumerSp) "messaging.destination.name" - `shouldBe` Just (envelope ^. #destination) - textAttr (csAttributes consumerSp) "messaging.destination.partition.id" - `shouldBe` Just "7" - textAttr (csAttributes consumerSp) "messaging.consumer.group.name" - `shouldBe` Just "billing-cg" - textAttr (csAttributes consumerSp) "messaging.message.id" - `shouldBe` Just (envelope ^. #messageId) - - describe "Keiro cross-context Kafka integration" $ around (withFreshStores2 fixture) $ do - it "publishes an Ordering integration event and runs the Billing handler exactly once across duplicate deliveries" $ \(ordering, billing) -> do - Right () <- - Store.runStoreIO billing $ - Store.runTransaction (Tx.sql "CREATE TABLE IF NOT EXISTS billing_received_orders (order_id TEXT PRIMARY KEY, quantity BIGINT NOT NULL)") - topic <- newKafkaTopic - -- Ordering side: enqueue an outbox row representing a published event. - let orderingEvent = orderSubmittedEnvelope "order-aaa" 7 "msg-aaa" - oid = OutboxId outboxUuid1 - Right () <- - Store.runStoreIO ordering $ - Store.runTransaction (enqueueIntegrationEventTx oid orderingEvent) - -- Run the publisher worker: push records to the in-process topic. - Right pubSummary1 <- - Store.runStoreIO ordering $ - publishClaimedOutbox (perRow (kafkaTopicPublish topic)) defaultPublishOptions Nothing - pubSummary1 ^. #published `shouldBe` 1 - -- Billing side: consume from the topic. - records1 <- drainKafkaTopic topic - record1 <- case records1 of - [r] -> pure r - other -> expectationFailure ("expected 1 record, got " <> show (length other)) *> error "unreachable" - Right consumed1 <- - Store.runStoreIO billing $ - consumeAndApply record1 billingReactionHandler - consumed1 `shouldBe` ConsumeApplied (InboxProcessed ()) - Right rowCount1 <- - Store.runStoreIO billing $ - Store.runTransaction (Tx.statement () billingReceivedOrdersCountStmt) - rowCount1 `shouldBe` 1 - - -- Simulate Kafka redelivery: pretend the same Kafka record was - -- delivered again at a different offset. The producer also retries - -- (the outbox flips back to pending and the worker republishes). - let redelivered = redeliverWithDifferentOffset record1 - Right consumed2 <- - Store.runStoreIO billing $ - consumeAndApply redelivered billingReactionHandler - consumed2 `shouldBe` ConsumeApplied InboxDuplicate - Right rowCount2 <- - Store.runStoreIO billing $ - Store.runTransaction (Tx.statement () billingReceivedOrdersCountStmt) - rowCount2 `shouldBe` 1 - - it "preserves per-partition ordering for two events sharing a Kafka key" $ \(ordering, billing) -> do - Right () <- - Store.runStoreIO billing $ - Store.runTransaction (Tx.sql "CREATE TABLE IF NOT EXISTS billing_received_orders (order_id TEXT PRIMARY KEY, quantity BIGINT NOT NULL)") - Right () <- - Store.runStoreIO billing $ - Store.runTransaction (Tx.sql "CREATE TABLE IF NOT EXISTS billing_event_log (seq BIGSERIAL PRIMARY KEY, source TEXT NOT NULL, event_type TEXT NOT NULL, order_id TEXT NOT NULL)") - topic <- newKafkaTopic - -- Two events for the same order key. - let submittedEnv = orderSubmittedEnvelope "order-bbb" 4 "msg-bbb-1" - cancelledEnv = orderCancelledEnvelope "order-bbb" "msg-bbb-2" - submittedId = OutboxId outboxUuid1 - cancelledId = OutboxId outboxUuid2 - Right () <- - Store.runStoreIO ordering $ - Store.runTransaction (enqueueIntegrationEventTx submittedId submittedEnv) - Right () <- - Store.runStoreIO ordering $ - Store.runTransaction (enqueueIntegrationEventTx cancelledId cancelledEnv) - -- Run-claiming lets a same-key contiguous run drain in one pass. - let drainOnce = - publishClaimedOutbox - (perRow (kafkaTopicPublish topic)) - (defaultPublishOptions & #backoff .~ ConstantBackoff 0) - Nothing - Right s1 <- Store.runStoreIO ordering drainOnce - Right s2 <- Store.runStoreIO ordering drainOnce - (s1 ^. #published) + (s2 ^. #published) `shouldBe` 2 - records <- drainKafkaTopic topic - length records `shouldBe` 2 - -- Apply both records to billing in delivery order. - for_ records $ \record -> do - Right consumed <- - Store.runStoreIO billing $ - consumeAndApply record (loggingReactionHandler "billing") - case consumed of - ConsumeApplied (InboxProcessed ()) -> pure () - other -> expectationFailure ("expected processed, got " <> show other) - Right events <- - Store.runStoreIO billing $ - Store.runTransaction (Tx.statement () billingEventLogStmt) - events `shouldBe` [("OrderSubmitted", "order-bbb"), ("OrderCancelled", "order-bbb")] - - it "head-of-line blocks a same-key successor when the first send fails repeatedly until the first row reaches dead status" $ \(ordering, billing) -> do - Right () <- - Store.runStoreIO billing $ - Store.runTransaction (Tx.sql "CREATE TABLE IF NOT EXISTS billing_received_orders (order_id TEXT PRIMARY KEY, quantity BIGINT NOT NULL)") - topic <- newKafkaTopic - let submittedEnv = orderSubmittedEnvelope "order-ccc" 1 "msg-ccc-1" - cancelledEnv = orderCancelledEnvelope "order-ccc" "msg-ccc-2" - firstId = OutboxId outboxUuid1 - secondId = OutboxId outboxUuid2 - Right () <- - Store.runStoreIO ordering $ - Store.runTransaction (enqueueIntegrationEventTx firstId submittedEnv) - Right () <- - Store.runStoreIO ordering $ - Store.runTransaction (enqueueIntegrationEventTx secondId cancelledEnv) - -- Failing publish for the first row, success for any other. - let publish row - | row ^. #outboxId == firstId = - pure (PublishFailed "simulated broker reject") - | otherwise = do - kafkaTopicAccept topic row - pure PublishSucceeded - deadOpts = - defaultPublishOptions - & #batchSize - .~ 1 - & #backoff - .~ ConstantBackoff 0 - & #maxAttempts - .~ 2 - -- This test drives the pre-M3 sequential failure/dead-letter path - -- with one-row batches. M3 adds suffix skipping for larger claimed - -- same-key runs. - -- First pass: the first row attempts once and fails; the second is - -- outside the one-row claim window. - Right pass1 <- Store.runStoreIO ordering (publishClaimedOutbox (perRow publish) deadOpts Nothing) - pass1 ^. #retried `shouldBe` 1 - pass1 ^. #published `shouldBe` 0 - -- Second pass crosses maxAttempts and dead-letters the first row. - Right pass2 <- Store.runStoreIO ordering (publishClaimedOutbox (perRow publish) deadOpts Nothing) - pass2 ^. #dead `shouldBe` 1 - Right (Just firstRow) <- Store.runStoreIO ordering (lookupOutbox firstId) - firstRow ^. #status `shouldBe` OutboxDead - -- With the first row dead, the second becomes claimable and publishes. - Right pass3 <- Store.runStoreIO ordering (publishClaimedOutbox (perRow publish) deadOpts Nothing) - pass3 ^. #published `shouldBe` 1 - Right (Just secondRow) <- Store.runStoreIO ordering (lookupOutbox secondId) - secondRow ^. #status `shouldBe` OutboxSent - -- Billing only sees the second event. - records <- drainKafkaTopic topic - record <- case records of - [r] -> pure r - other -> expectationFailure ("expected 1 record, got " <> show (length other)) *> error "unreachable" - Right consumed <- - Store.runStoreIO billing $ - consumeAndApply record billingReactionHandler - consumed `shouldBe` ConsumeApplied (InboxProcessed ()) - - describe "Keiro.Integration.Event" $ do - it "round-trips a JSON envelope through encode and decode" $ do - let envelope = sampleIntegrationEnvelope - payload = OrderSubmittedPayload "order-123" 5 - encoded = encodeJsonIntegrationEvent envelope payload - decodeJsonIntegrationEvent encoded `shouldBe` Right payload - - it "preserves identity and routing through encode" $ do - let envelope = sampleIntegrationEnvelope - encoded = encodeJsonIntegrationEvent envelope (OrderSubmittedPayload "order-123" 5) - encoded ^. #messageId `shouldBe` envelope ^. #messageId - encoded ^. #source `shouldBe` "ordering" - encoded ^. #destination `shouldBe` "billing.orders.v1" - encoded ^. #key `shouldBe` Just "order-123" - encoded ^. #eventType `shouldBe` "OrderSubmitted" - encoded ^. #schemaVersion `shouldBe` 1 - encoded ^. #contentType `shouldBe` ApplicationJson - - it "emits the canonical wire headers" $ do - let envelope = sampleIntegrationEnvelope - headers = integrationHeaders envelope - Prelude.lookup headerMessageId headers `shouldBe` Just (envelope ^. #messageId) - Prelude.lookup headerSchemaVersion headers `shouldBe` Just "1" - Prelude.lookup headerContentType headers `shouldBe` Just "application/json" - Prelude.lookup headerSchemaSubject headers `shouldBe` Just "billing.orders.v1.OrderSubmitted" - Prelude.lookup headerSourceEventId headers `shouldBe` Just "018f0f18-17aa-7000-8000-000000000003" - Prelude.lookup headerSourceGlobalPosition headers `shouldBe` Just "42" - Prelude.lookup headerTraceParent headers - `shouldBe` Just "00-0af7651916cd43dd8448eb211c80319c-b7ad6b7169203331-01" - - it "preserves a different content type without claiming JSON" $ do - let envelope = - sampleIntegrationEnvelope - & #contentType - .~ OtherContentType "application/vnd.apache.avro.binary" - & #payloadBytes - .~ "\x00\x01\x02" - headers = integrationHeaders envelope - Prelude.lookup headerContentType headers - `shouldBe` Just "application/vnd.apache.avro.binary" - decodeJsonIntegrationEvent envelope - `shouldBe` ( Left (IntegrationEvent.UnsupportedContentType "application/vnd.apache.avro.binary") :: - Either IntegrationEvent.IntegrationEventError OrderSubmittedPayload - ) - - it "reports malformed JSON payloads as decode errors instead of throwing" $ do - let envelope = - sampleIntegrationEnvelope - & #payloadBytes - .~ "{not-json" - case decodeJsonIntegrationEvent envelope :: Either IntegrationEvent.IntegrationEventError OrderSubmittedPayload of - Left (IntegrationEvent.MalformedPayload _) -> pure () - other -> expectationFailure ("expected MalformedPayload, got " <> show other) - - it "reports a JSON value that does not satisfy the target type as DecodeFailed" $ do - let envelope = - sampleIntegrationEnvelope - & #payloadBytes - .~ "{\"orderId\":\"order-123\"}" - case decodeJsonIntegrationEvent envelope :: Either IntegrationEvent.IntegrationEventError OrderSubmittedPayload of - Left (IntegrationEvent.DecodeFailed _) -> pure () - other -> expectationFailure ("expected DecodeFailed, got " <> show other) - - it "parses content-type headers back to the canonical type" $ do - parseContentType "application/json" `shouldBe` ApplicationJson - parseContentType "Application/JSON" `shouldBe` ApplicationJson - parseContentType "application/json; charset=utf-8" `shouldBe` ApplicationJson - parseContentType "APPLICATION/JSON ; CHARSET=UTF-8" `shouldBe` ApplicationJson - parseContentType "application/vnd.apache.avro.binary" - `shouldBe` OtherContentType "application/vnd.apache.avro.binary" - - it "preserves the payload bytes through integrationPayload" $ do - let envelope = sampleIntegrationEnvelope - encoded = encodeJsonIntegrationEvent envelope (OrderSubmittedPayload "order-123" 5) - integrationPayload encoded `shouldBe` (encoded ^. #payloadBytes) - - describe "Keiro.Telemetry" $ do - it "is a pass-through under a noop (Nothing) tracer" $ do - counter <- newIORef (0 :: Int) - let envelope = sampleIntegrationEnvelope - record = OutboxKafka.integrationEventToKafkaRecord envelope - result <- - Telemetry.withProducerSpan Nothing envelope record $ \mSpan -> do - atomicModifyIORef' counter (\n -> (n + 1, ())) - pure (mSpan, "ok" :: Text) - callsAfter <- readIORef counter - callsAfter `shouldBe` (1 :: Int) - snd result `shouldBe` "ok" - fst result `shouldSatisfy` isNothing - - it "re-exports AttributeKeys whose textual payload matches the spec name" $ do - attrKeyText Telemetry.messaging_operation_type `shouldBe` "messaging.operation.type" - attrKeyText Telemetry.messaging_operation_name `shouldBe` "messaging.operation.name" - attrKeyText Telemetry.messaging_destination_partition_id `shouldBe` "messaging.destination.partition.id" - attrKeyText Telemetry.messaging_consumer_group_name `shouldBe` "messaging.consumer.group.name" - attrKeyText Telemetry.messaging_client_id `shouldBe` "messaging.client.id" - attrKeyTextInt64 Telemetry.messaging_kafka_offset `shouldBe` "messaging.kafka.offset" - attrKeyText Telemetry.db_system_name `shouldBe` "db.system.name" - attrKeyText Telemetry.db_namespace `shouldBe` "db.namespace" - attrKeyText Telemetry.db_collection_name `shouldBe` "db.collection.name" - attrKeyText Telemetry.db_operation_name `shouldBe` "db.operation.name" - attrKeyText Telemetry.keiro_stream_name `shouldBe` "keiro.stream.name" - attrKeyTextInt64 Telemetry.keiro_retry_attempt `shouldBe` "keiro.retry.attempt" - attrKeyTextInt64 Telemetry.keiro_events_appended `shouldBe` "keiro.events.appended" - attrKeyText Telemetry.keiro_replay_divergence `shouldBe` "keiro.replay.divergence" - - it "extracts a TraceContext from a W3C traceparent header pair" $ do - let traceparent = "00-0af7651916cd43dd8448eb211c80319c-b7ad6b7169203331-01" - tracestate = "vendor1=value1" - hs = [(headerTraceParent, traceparent), ("tracestate", tracestate)] - Telemetry.traceContextFromHeaders hs - `shouldBe` Just (TraceContext traceparent (Just tracestate)) - - it "returns Nothing when the traceparent header is missing" $ do - Telemetry.traceContextFromHeaders [("content-type", "application/json")] - `shouldBe` Nothing - - it "injectTraceContext is a no-op when no span is active on the thread" $ do - let baseline = [("content-type", "application/json")] - injected <- Telemetry.injectTraceContext baseline - injected `shouldBe` baseline - - it "traceContextFromCurrentSpan returns Nothing outside any span" $ do - tc <- Telemetry.traceContextFromCurrentSpan - tc `shouldBe` Nothing - - describe "Keiro.Workflow" $ around (withFreshStore fixture) $ do - it "journals each step once, returns Completed, and runs each side effect once" $ \storeHandle -> do - counter <- newIORef (0 :: Int) - let name = WorkflowName "demo" - wid = WorkflowId "demo-1" - result <- Store.runStoreIO storeHandle $ runWorkflow name wid (demoWorkflow counter) - result `shouldBe` Right (Completed (1, 2)) - sideEffects <- readIORef counter - sideEffects `shouldBe` 2 - Right recorded <- - Store.runStoreIO storeHandle $ - Store.readStreamForward (StreamName "wf:demo-demo-1") (StreamVersion 0) 10 - Vector.length recorded `shouldBe` 3 - traverse (decodeRecorded workflowJournalCodec) (Vector.toList recorded) - `shouldSatisfy` \case - Right [StepRecorded "first" _ _, StepRecorded "second" _ _, WorkflowCompleted _] -> True - _ -> False - - it "replays recorded steps without re-running their side effects" $ \storeHandle -> do - counter <- newIORef (0 :: Int) - let name = WorkflowName "replay" - wid = WorkflowId "r-1" - first <- Store.runStoreIO storeHandle $ runWorkflow name wid (demoWorkflow counter) - first `shouldBe` Right (Completed (1, 2)) - afterFirst <- readIORef counter - afterFirst `shouldBe` 2 - -- A second run with the same id is exactly the crash-restart scenario. - second <- Store.runStoreIO storeHandle $ runWorkflow name wid (demoWorkflow counter) - second `shouldBe` Right (Completed (1, 2)) - afterSecond <- readIORef counter - afterSecond `shouldBe` 2 - -- The deterministic ids and pre-load gating leave the journal at 3 events. - Right recorded <- - Store.runStoreIO storeHandle $ - Store.readStreamForward (StreamName "wf:replay-r-1") (StreamVersion 0) 10 - Vector.length recorded `shouldBe` 3 - - it "reuses the recorded result for a repeated step name in one run" $ \storeHandle -> do - counter <- newIORef (0 :: Int) - let name = WorkflowName "samename" - wid = WorkflowId "s-1" - duplicateStepWorkflow = do - a <- step (StepName "dup") (liftIO (incrementAndRead counter)) - b <- step (StepName "dup") (liftIO (incrementAndRead counter)) - pure (a, b) - result <- Store.runStoreIO storeHandle $ runWorkflow name wid duplicateStepWorkflow - result `shouldBe` Right (Completed (1, 1)) - sideEffects <- readIORef counter - sideEffects `shouldBe` 1 - - it "suspends on an unresolved awaitStep, journaling no completion" $ \storeHandle -> do - let name = WorkflowName "awaiter" - wid = WorkflowId "a-1" - result <- Store.runStoreIO storeHandle $ runWorkflow name wid neverArmingWorkflow - result `shouldBe` Right Suspended - Right recorded <- - Store.runStoreIO storeHandle $ - Store.readStreamForward (StreamName "wf:awaiter-a-1") (StreamVersion 0) 10 - Vector.length recorded `shouldBe` 0 - - it "resumes and completes once an awaited step is externally completed" $ \storeHandle -> do - let name = WorkflowName "awaiter2" - wid = WorkflowId "a-2" - suspended <- Store.runStoreIO storeHandle $ runWorkflow name wid neverArmingWorkflow - suspended `shouldBe` Right Suspended - -- Simulate a wake source recording the awaited step's resolution. - Right () <- Store.runStoreIO storeHandle $ do - now <- liftIO getCurrentTime - appendJournalEntry name wid (StepRecorded "awk:test" (toJSON (42 :: Int)) now) - resumed <- Store.runStoreIO storeHandle $ runWorkflow name wid neverArmingWorkflow - resumed `shouldBe` Right (Completed 42) - Right recorded <- - Store.runStoreIO storeHandle $ - Store.readStreamForward (StreamName "wf:awaiter2-a-2") (StreamVersion 0) 10 - traverse (decodeRecorded workflowJournalCodec) (Vector.toList recorded) - `shouldSatisfy` \case - Right [StepRecorded "awk:test" _ _, WorkflowCompleted _] -> True - _ -> False - - it "treats a duplicate external journal append as idempotent" $ \storeHandle -> do - let name = WorkflowName "duplicate-append" - wid = WorkflowId "da-1" - stepKey = "awk:test" - eventAt t = StepRecorded stepKey (toJSON (42 :: Int)) t - now <- getCurrentTime - Right firstId <- - Store.runStoreIO storeHandle $ - appendJournalEntryReturningId name wid (eventAt now) - secondResult <- - Store.runStoreIO storeHandle $ - appendJournalEntryReturningId name wid (eventAt now) - secondId <- case secondResult of - Right value -> pure value - Left err -> expectationFailure ("expected idempotent duplicate append, got " <> show err) *> error "unreachable" - secondId `shouldBe` firstId - Right indexed <- Store.runStoreIO storeHandle $ loadStepIndex name wid 0 - Map.lookup stepKey indexed `shouldBe` Just (toJSON (42 :: Int)) - Right recorded <- - Store.runStoreIO storeHandle $ - Store.readStreamForward (StreamName "wf:duplicate-append-da-1") (StreamVersion 0) 10 - Vector.length recorded `shouldBe` 1 - - it "returns the journaled value when another writer records the same step mid-flight" $ \storeHandle -> do - let name = WorkflowName "journal-race" - wid = WorkflowId "jr-1" - body = - step (StepName "raced") $ do - now <- liftIO getCurrentTime - appendJournalEntry name wid (StepRecorded "raced" (toJSON ("winner" :: Text)) now) - pure ("loser" :: Text) - outcome <- Store.runStoreIO storeHandle $ runWorkflow name wid body - outcome `shouldBe` Right (Completed "winner") - Right recorded <- - Store.runStoreIO storeHandle $ - Store.readStreamForward (StreamName "wf:journal-race-jr-1") (StreamVersion 0) 10 - traverse (decodeRecorded workflowJournalCodec) (Vector.toList recorded) - `shouldSatisfy` \case - Right [StepRecorded "raced" value _, WorkflowCompleted _] -> value == toJSON ("winner" :: Text) - _ -> False - - it "returns the JSON round-trip of a fresh step result" $ \storeHandle -> do - let name = WorkflowName "roundtrip-step" - wid = WorkflowId "rs-1" - body = step (StepName "approx") (pure (Approx 1.7)) - first <- Store.runStoreIO storeHandle $ runWorkflow name wid body - first `shouldBe` Right (Completed (Approx 2.0)) - replay <- Store.runStoreIO storeHandle $ runWorkflow name wid body - replay `shouldBe` Right (Completed (Approx 2.0)) - - it "throws WorkflowStepDecodeError on the first run when the recorded result cannot decode" $ \storeHandle -> do - let name = WorkflowName "bad-roundtrip" - wid = WorkflowId "br-1" - body = step (StepName "bad") (pure RejectingRoundTrip) - Store.runStoreIO storeHandle (runWorkflow name wid body) - `shouldThrow` \case - WorkflowStepDecodeError key _ -> key == "bad" - _ -> False - Store.runStoreIO storeHandle (stepExists name wid 0 "bad") - `shouldReturn` Right True - - it "discovers unfinished workflows via the step index" $ \storeHandle -> do - counter <- newIORef (0 :: Int) - Right (Completed _) <- - Store.runStoreIO storeHandle $ - runWorkflow (WorkflowName "done") (WorkflowId "d-1") (demoWorkflow counter) - Right Suspended <- - Store.runStoreIO storeHandle $ - runWorkflow (WorkflowName "pending") (WorkflowId "p-1") (stepThenAwaitWorkflow counter) - now <- getCurrentTime - Right unfinished <- Store.runStoreIO storeHandle (findUnfinishedWorkflowIds now) - unfinished `shouldBe` [("p-1", "pending")] - - describe "Keiro.Workflow instance table" $ around (withFreshStore fixture) $ do - it "creates and completes a workflow instance row transactionally with the journal" $ \storeHandle -> do - counter <- newIORef (0 :: Int) - let name = WorkflowName "inst-complete" - wid = WorkflowId "ic-1" - Right (Completed _) <- Store.runStoreIO storeHandle $ runWorkflow name wid (demoWorkflow counter) - Right (Just row) <- Store.runStoreIO storeHandle $ Instance.lookupInstance name wid - row ^. #workflowId `shouldBe` "ic-1" - row ^. #workflowName `shouldBe` "inst-complete" - row ^. #generation `shouldBe` 0 - row ^. #status `shouldBe` Instance.WfCompleted - row ^. #completedAt `shouldSatisfy` isJust - - it "records suspended status for workflows that park before journaling" $ \storeHandle -> do - let name = WorkflowName "inst-suspended" - wid = WorkflowId "is-1" - Right Suspended <- Store.runStoreIO storeHandle $ runWorkflow name wid neverArmingWorkflow - Right (Just row) <- Store.runStoreIO storeHandle $ Instance.lookupInstance name wid - row ^. #status `shouldBe` Instance.WfSuspended - row ^. #generation `shouldBe` 0 - row ^. #completedAt `shouldBe` Nothing - - it "creates child instance rows at spawn time and flips them to cancelled" $ \storeHandle -> do - let childWid = WorkflowId "inst-child" - childName = WorkflowName "ship" - Right Suspended <- - Store.runStoreIO storeHandle $ - runWorkflow (WorkflowName "inst-parent") (WorkflowId "ip-1") (parentWorkflow childWid) - Right (Just spawned) <- Store.runStoreIO storeHandle $ Instance.lookupInstance childName childWid - spawned ^. #status `shouldBe` Instance.WfRunning - Right True <- Store.runStoreIO storeHandle $ cancelChild (ChildHandle childName childWid) - Right (Just cancelledRow) <- Store.runStoreIO storeHandle $ Instance.lookupInstance childName childWid - cancelledRow ^. #status `shouldBe` Instance.WfCancelled - cancelledRow ^. #completedAt `shouldSatisfy` isJust - - it "bumps the instance generation when continueAsNew rotates" $ \storeHandle -> do - counter <- newIORef (0 :: Int) - let name = WorkflowName "inst-rotate" - wid = WorkflowId "ir-1" - Right ContinuedAsNew <- - Store.runStoreIO storeHandle $ - runWorkflow name wid (rollingTotal counter 1 2) - Right (Just row) <- Store.runStoreIO storeHandle $ Instance.lookupInstance name wid - row ^. #generation `shouldBe` 1 - row ^. #status `shouldBe` Instance.WfRunning - - it "does not let a late append resurrect a terminal instance row" $ \storeHandle -> do - counter <- newIORef (0 :: Int) - let name = WorkflowName "inst-terminal" - wid = WorkflowId "it-1" - Right (Completed _) <- Store.runStoreIO storeHandle $ runWorkflow name wid (demoWorkflow counter) - now <- getCurrentTime - Right () <- - Store.runStoreIO storeHandle $ - appendJournalEntry name wid (StepRecorded "late" (toJSON True) now) - Right (Just row) <- Store.runStoreIO storeHandle $ Instance.lookupInstance name wid - row ^. #status `shouldBe` Instance.WfCompleted - - it "discovers unfinished workflows from the instance table" $ \storeHandle -> do - counter <- newIORef (0 :: Int) - let completedName = WorkflowName "discover-completed" - cancelledName = WorkflowName "discover-cancelled" - crashedName = WorkflowName "discover-crashed" - rotatedName = WorkflowName "discover-rotated" - Right (Completed _) <- - Store.runStoreIO storeHandle $ - runWorkflow completedName (WorkflowId "done") (demoWorkflow counter) - cancelledAt <- getCurrentTime - Right () <- - Store.runStoreIO storeHandle $ - appendJournalEntry cancelledName (WorkflowId "cancelled") (WorkflowCancelled cancelledAt) - Left (_ :: SimulatedCrash) <- - try $ - Store.runStoreIO storeHandle $ - runWorkflow crashedName (WorkflowId "crashed") (crashAfterStep1 counter) - Right ContinuedAsNew <- - Store.runStoreIO storeHandle $ - runWorkflow rotatedName (WorkflowId "rotated") (rollingTotal counter 1 2) - now <- getCurrentTime - Right unfinished <- Store.runStoreIO storeHandle (findUnfinishedWorkflowIds now) - unfinished - `shouldBe` [ ("crashed", "discover-crashed") - , ("rotated", "discover-rotated") - ] - - describe "Keiro.Workflow snapshots" $ around (withFreshStore fixture) $ do - it "does not fail committed workflow steps when snapshot writes fail" $ \storeHandle -> do - (exporter, metricsRef) <- inMemoryMetricExporter - (provider, _env) <- - createMeterProvider - emptyMaterializedResources - defaultSdkMeterProviderOptions{metricExporter = Just exporter} - meter <- getMeter provider Telemetry.keiroInstrumentationLibrary - keiroMetrics <- Telemetry.newKeiroMetrics meter - let opts = - defaultWorkflowRunOptions - & #snapshotPolicy - .~ Every 2 - & #metrics - ?~ keiroMetrics - Right () <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ - Tx.sql "ALTER TABLE keiro.keiro_snapshots ADD CONSTRAINT keiro_snapshots_no_writes CHECK (false) NOT VALID" - counter <- newIORef (0 :: Int) - result <- - Store.runStoreIO storeHandle $ - runWorkflowWith opts (WorkflowName "snap-write-failure") (WorkflowId "wf1") (countingSixSteps counter) - result `shouldBe` Right (Completed [1, 2, 3, 4, 5, 6]) - Right journal <- - Store.runStoreIO storeHandle $ - Store.readStreamForward (StreamName "wf:snap-write-failure-wf1") (StreamVersion 0) 100 - Vector.length journal `shouldBe` 7 - Right snapshotVersionDuringFailure <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ - Tx.statement "wf:snap-write-failure-wf1" snapshotVersionForStreamStmt - snapshotVersionDuringFailure `shouldBe` Nothing - _ <- forceFlushMeterProvider provider Nothing - exported <- readIORef metricsRef - lookup "keiro.snapshot.write.failures" (flattenScalarPoints exported) `shouldBe` Just (IntNumber 3) - Right () <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ - Tx.sql "ALTER TABLE keiro.keiro_snapshots DROP CONSTRAINT keiro_snapshots_no_writes" - recoveryCounter <- newIORef (0 :: Int) - recovery <- - Store.runStoreIO storeHandle $ - runWorkflowWith opts (WorkflowName "snap-write-recovery") (WorkflowId "wf2") (countingSixSteps recoveryCounter) - recovery `shouldBe` Right (Completed [1, 2, 3, 4, 5, 6]) - Right snapshotVersionAfterRecovery <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ - Tx.statement "wf:snap-write-recovery-wf2" snapshotVersionForStreamStmt - snapshotVersionAfterRecovery `shouldBe` Just (StreamVersion 6) - - -- Validation (a): a snapshot row appears at the expected version and - -- decodes to the full accumulated step map. - it "writes a snapshot of the accumulated step map after Every 2 fires" $ \storeHandle -> do - counter <- newIORef (0 :: Int) - let name = WorkflowName "snap" - wid = WorkflowId "w1" - result <- - Store.runStoreIO storeHandle $ - runWorkflowWith - (defaultWorkflowRunOptions & #snapshotPolicy .~ Every 2) - name - wid - (countingSixSteps counter) - result `shouldBe` Right (Completed [1, 2, 3, 4, 5, 6]) - -- Every 2 fired at versions 2, 4, 6; the upsert keeps the highest (6). - Right snapVersion <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ - Tx.statement "wf:snap-w1" snapshotVersionForStreamStmt - snapVersion `shouldBe` Just (StreamVersion 6) - -- and the row decodes to the six-entry accumulated map. - Right mSeed <- Store.runStoreIO storeHandle $ loadWorkflowSnapshot (StreamName "wf:snap-w1") - case mSeed of - Just (m, v) -> do - v `shouldBe` StreamVersion 6 - Map.keys m `shouldBe` ["s1", "s2", "s3", "s4", "s5", "s6"] - Nothing -> expectationFailure "expected a workflow snapshot row" - - -- The OnTerminal completion-site wiring: only the final WorkflowCompleted - -- append (version 7) triggers the snapshot. - it "writes a terminal snapshot under OnTerminal at the completion version" $ \storeHandle -> do - counter <- newIORef (0 :: Int) - let name = WorkflowName "term" - wid = WorkflowId "tm1" - result <- - Store.runStoreIO storeHandle $ - runWorkflowWith - (defaultWorkflowRunOptions & #snapshotPolicy .~ OnTerminal) - name - wid - (countingSixSteps counter) - result `shouldBe` Right (Completed [1, 2, 3, 4, 5, 6]) - Right snapVersion <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ - Tx.statement "wf:term-tm1" snapshotVersionForStreamStmt - snapVersion `shouldBe` Just (StreamVersion 7) - - -- Validation (b): re-hydration reads only the tail after the snapshot - -- version, and the journaled steps short-circuit (the counter stays put). - it "reads only the tail after the snapshot version on re-hydration" $ \storeHandle -> do - counter <- newIORef (0 :: Int) - let name = WorkflowName "tail" - wid = WorkflowId "t1" - opts = defaultWorkflowRunOptions & #snapshotPolicy .~ Every 2 - first <- Store.runStoreIO storeHandle $ runWorkflowWith opts name wid (countingSixSteps counter) - first `shouldBe` Right (Completed [1, 2, 3, 4, 5, 6]) - afterFirst <- readIORef counter - afterFirst `shouldBe` 6 - -- A full version-0 replay would read every journal event... - Right full <- - Store.runStoreIO storeHandle $ - Store.readStreamForward (StreamName "wf:tail-t1") (StreamVersion 0) 100 - Vector.length full `shouldBe` 7 -- six StepRecorded + one WorkflowCompleted - -- ...whereas the runtime seeds from the snapshot and reads only the tail. - Right (Just (seedMap, StreamVersion sv)) <- - Store.runStoreIO storeHandle $ loadWorkflowSnapshot (StreamName "wf:tail-t1") - Map.size seedMap `shouldBe` 6 - Right tailEvents <- - Store.runStoreIO storeHandle $ - Store.readStreamForward (StreamName "wf:tail-t1") (StreamVersion sv) 100 - Vector.length tailEvents `shouldSatisfy` (< Vector.length full) - Vector.length tailEvents `shouldBe` 1 -- only the WorkflowCompleted at v7 - -- Re-hydration completes from the seed without re-running any step. - second <- Store.runStoreIO storeHandle $ runWorkflowWith opts name wid (countingSixSteps counter) - second `shouldBe` Right (Completed [1, 2, 3, 4, 5, 6]) - afterSecond <- readIORef counter - afterSecond `shouldBe` 6 - - -- Validation (c): a Never run and an Every 2 run produce identical results - -- and identical journals, and the snapshot seed equals a full replay. - it "produces identical results and journals under Never and Every 2" $ \storeHandle -> do - counterN <- newIORef (0 :: Int) - counterE <- newIORef (0 :: Int) - neverRes <- - Store.runStoreIO storeHandle $ - runWorkflowWith - (defaultWorkflowRunOptions & #snapshotPolicy .~ Never) - (WorkflowName "corr-never") - (WorkflowId "c1") - (countingSixSteps counterN) - everyRes <- - Store.runStoreIO storeHandle $ - runWorkflowWith - (defaultWorkflowRunOptions & #snapshotPolicy .~ Every 2) - (WorkflowName "corr-every") - (WorkflowId "c1") - (countingSixSteps counterE) - neverRes `shouldBe` Right (Completed [1, 2, 3, 4, 5, 6]) - everyRes `shouldBe` Right (Completed [1, 2, 3, 4, 5, 6]) - Right neverEvents <- - Store.runStoreIO storeHandle $ - Store.readStreamForward (StreamName "wf:corr-never-c1") (StreamVersion 0) 100 - Right everyEvents <- - Store.runStoreIO storeHandle $ - Store.readStreamForward (StreamName "wf:corr-every-c1") (StreamVersion 0) 100 - let stepResults evs = - [ (k, v) - | Right (StepRecorded k v _) <- decodeRecorded workflowJournalCodec <$> Vector.toList evs - ] - stepResults neverEvents `shouldBe` stepResults everyEvents - -- The snapshot seed equals the map a full version-0 replay would fold. - Right (Just (seedMap, _)) <- - Store.runStoreIO storeHandle $ loadWorkflowSnapshot (StreamName "wf:corr-every-c1") - seedMap `shouldBe` Map.fromList (stepResults everyEvents) - - -- Validation (d): an advisory snapshot whose discriminant no longer matches - -- is ignored and the workflow hydrates via full replay. - it "hydrates via full replay when the snapshot discriminant mismatches" $ \storeHandle -> do - counter <- newIORef (0 :: Int) - let name = WorkflowName "dmiss" - wid = WorkflowId "d1" - opts = defaultWorkflowRunOptions & #snapshotPolicy .~ Every 2 - _ <- Store.runStoreIO storeHandle $ runWorkflowWith opts name wid (countingSixSteps counter) - Right () <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ - Tx.statement ("wf:dmiss-d1", "stale-shape") corruptSnapshotShapeStmt - Right mSeed <- Store.runStoreIO storeHandle $ loadWorkflowSnapshot (StreamName "wf:dmiss-d1") - mSeed `shouldBe` Nothing - resumed <- Store.runStoreIO storeHandle $ runWorkflowWith opts name wid (countingSixSteps counter) - resumed `shouldBe` Right (Completed [1, 2, 3, 4, 5, 6]) - - -- Validation (d), second arm: corrupt snapshot JSON is treated as a miss. - it "hydrates via full replay when the snapshot JSON is corrupt" $ \storeHandle -> do - (exporter, metricsRef) <- inMemoryMetricExporter - (provider, _env) <- - createMeterProvider - emptyMaterializedResources - defaultSdkMeterProviderOptions{metricExporter = Just exporter} - meter <- getMeter provider Telemetry.keiroInstrumentationLibrary - keiroMetrics <- Telemetry.newKeiroMetrics meter - counter <- newIORef (0 :: Int) - let name = WorkflowName "cjson" - wid = WorkflowId "d2" - opts = - defaultWorkflowRunOptions - & #snapshotPolicy - .~ Every 2 - & #metrics - ?~ keiroMetrics - _ <- Store.runStoreIO storeHandle $ runWorkflowWith opts name wid (countingSixSteps counter) - Right () <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ - Tx.statement ("wf:cjson-d2", Aeson.String "bad") corruptSnapshotStateStmt - Right mSeed <- Store.runStoreIO storeHandle $ loadWorkflowSnapshot (StreamName "wf:cjson-d2") - mSeed `shouldBe` Nothing - resumed <- Store.runStoreIO storeHandle $ runWorkflowWith opts name wid (countingSixSteps counter) - resumed `shouldBe` Right (Completed [1, 2, 3, 4, 5, 6]) - _ <- forceFlushMeterProvider provider Nothing - exported <- readIORef metricsRef - let scalars = flattenScalarPoints exported - lookup "keiro.snapshot.decode.failures" scalars `shouldBe` Just (IntNumber 1) - lookup "keiro.snapshot.read.misses" scalars `shouldBe` Just (IntNumber 2) - - describe "Keiro.Workflow snapshot wake-safety" $ around (withFreshStore fixture) $ do - it "keeps a genuinely unresolved awakeable pending under Every 1" $ \storeHandle -> do - aidRef <- newIORef Nothing - let name = WorkflowName "snapshot-unsignalled" - wid = WorkflowId "wf1" - opts = defaultWorkflowRunOptions & #snapshotPolicy .~ Every 1 - run = Store.runStoreIO storeHandle $ runWorkflowWith opts name wid (snapshotUnsignalledAwakeable aidRef) - first <- run - first `shouldBe` Right Suspended - aid <- readRequiredAwakeableId aidRef - Right (Just rowAfterFirst) <- Store.runStoreIO storeHandle $ Awk.lookupAwakeable (awakeableIdToUuid aid) - rowAfterFirst ^. #status `shouldBe` Awk.Pending - rowAfterFirst ^. #payload `shouldBe` Nothing - second <- run - second `shouldBe` Right Suspended - Right (Just rowAfterSecond) <- Store.runStoreIO storeHandle $ Awk.lookupAwakeable (awakeableIdToUuid aid) - rowAfterSecond ^. #status `shouldBe` Awk.Pending - rowAfterSecond ^. #payload `shouldBe` Nothing - - it "delivers an awakeable signalled mid-run despite the stale in-memory map" $ \storeHandle -> do - aidRef <- newIORef Nothing - let name = WorkflowName "snapshot-midrun-awakeable" - wid = WorkflowId "wf1" - opts = defaultWorkflowRunOptions & #snapshotPolicy .~ Every 1 - run = Store.runStoreIO storeHandle $ runWorkflowWith opts name wid snapshotShadowedAwakeable - armed <- - Store.runStoreIO storeHandle $ - runWorkflowWith opts name wid (snapshotUnsignalledAwakeable aidRef) - armed `shouldBe` Right Suspended - first <- run - first `shouldBe` Right (Completed "payload") - second <- run - second `shouldBe` Right (Completed "payload") - - it "delivers an awakeable shadowed by a snapshot on a later run" $ \storeHandle -> do - aidRef <- newIORef Nothing - let name = WorkflowName "snapshot-stale-awakeable" - wid = WorkflowId "wf1" - opts = defaultWorkflowRunOptions & #snapshotPolicy .~ Every 1 - armed <- - Store.runStoreIO storeHandle $ - runWorkflowWith opts name wid (snapshotUnsignalledAwakeable aidRef) - armed `shouldBe` Right Suspended - first <- - Store.runStoreIO storeHandle $ - runWorkflowWith opts name wid (snapshotStaleAwakeablePhaseOne aidRef) - first `shouldBe` Right Suspended - aid <- readRequiredAwakeableId aidRef - Right (Just (staleSeed, _)) <- - Store.runStoreIO storeHandle $ - loadWorkflowSnapshot (workflowGenerationStreamName name wid 0) - staleSeed `shouldSatisfy` Map.notMember ("awk:" <> awakeableIdText aid) - second <- - Store.runStoreIO storeHandle $ - runWorkflowWith opts name wid snapshotStaleAwakeablePhaseTwo - second `shouldBe` Right (Completed "payload") - - it "delivers a child completion shadowed by a snapshot on a later run" $ \storeHandle -> do - let name = WorkflowName "snapshot-stale-child-parent" - wid = WorkflowId "wf1" - childWid = WorkflowId "child1" - opts = defaultWorkflowRunOptions & #snapshotPolicy .~ Every 1 - first <- - Store.runStoreIO storeHandle $ - runWorkflowWith opts name wid (snapshotStaleChildPhaseOne childWid) - first `shouldBe` Right Suspended - Right (Just (staleSeed, _)) <- - Store.runStoreIO storeHandle $ - loadWorkflowSnapshot (workflowGenerationStreamName name wid 0) - staleSeed `shouldSatisfy` Map.notMember (childResultStepName childWid) - second <- - Store.runStoreIO storeHandle $ - runWorkflowWith opts name wid (snapshotStaleChildPhaseTwo childWid) - second `shouldBe` Right (Completed "packed+labelled") - - describe "Keiro.Workflow.Resume" $ around (withFreshStore fixture) $ do - -- M2: crash mid-run, then a resume pass drives the workflow to Completed - -- without re-running the already-journaled step. - it "resumes a crashed mid-run workflow, running only the un-journaled tail" $ \storeHandle -> do - counter <- newIORef (0 :: Int) - let name = WorkflowName "crash-demo" - wid = WorkflowId "cd-1" - -- Simulate a crash after step 1's append has committed. - crashed <- - try - ( Store.runStoreIO storeHandle $ - runWorkflow name wid (crashAfterStep1 counter) - ) :: - IO (Either SomeException (Either Store.StoreError (WorkflowOutcome (Int, Int, Int)))) - case crashed of - Left _ -> pure () -- the SimulatedCrash unwound the run, as intended - Right other -> expectationFailure ("expected a simulated crash, got " <> show other) - readIORef counter >>= \c -> c `shouldBe` 1 - -- Resume with a registry mapping the name to the FULL definition. - let registry = Map.singleton name (WorkflowDef (\_wid -> threeStep counter)) - Right summary <- - Store.runStoreIO storeHandle $ resumeWorkflowsOnce defaultWorkflowResumeOptions registry - summary - `shouldBe` ResumeSummary - { discovered = 1 - , resumed = 1 - , completed = 1 - , stillSuspended = 0 - , unknownName = 0 - , failed = 0 - , transientErrors = 0 - , leaseSkipped = 0 - } - -- Step 1 short-circuited; steps 2 and 3 ran exactly once. - readIORef counter >>= \c -> c `shouldBe` 3 - -- The journal now holds s1, s2, s3, WorkflowCompleted. - Right recorded <- - Store.runStoreIO storeHandle $ - Store.readStreamForward (StreamName "wf:crash-demo-cd-1") (StreamVersion 0) 10 - traverse (decodeRecorded workflowJournalCodec) (Vector.toList recorded) - `shouldSatisfy` \case - Right [StepRecorded "s1" _ _, StepRecorded "s2" _ _, StepRecorded "s3" _ _, WorkflowCompleted _] -> True - _ -> False - -- A second pass discovers nothing — the workflow is finished. - Right summary2 <- - Store.runStoreIO storeHandle $ resumeWorkflowsOnce defaultWorkflowResumeOptions registry - summary2 `shouldBe` emptyResumeSummary - - -- M3: a workflow suspended on an awaited step is driven to Completed once - -- that step is journaled (here simulated; an EP-39/EP-40 wake source would - -- journal the same StepRecorded end to end). - it "resumes a suspended workflow once its awaited step is journaled" $ \storeHandle -> do - counter <- newIORef (0 :: Int) - let name = WorkflowName "await-demo" - wid = WorkflowId "ad-1" - suspended <- - Store.runStoreIO storeHandle $ runWorkflow name wid (awaitingThenStep counter) - suspended `shouldBe` Right Suspended - -- Simulate the wake source resolving the await. - Right () <- Store.runStoreIO storeHandle $ do - now <- liftIO getCurrentTime - appendJournalEntry name wid (StepRecorded "awk:approval" (toJSON ("ok" :: Text)) now) - let registry = Map.singleton name (WorkflowDef (\_wid -> awaitingThenStep counter)) - Right summary <- - Store.runStoreIO storeHandle $ resumeWorkflowsOnce defaultWorkflowResumeOptions registry - summary - `shouldBe` ResumeSummary - { discovered = 1 - , resumed = 1 - , completed = 1 - , stillSuspended = 0 - , unknownName = 0 - , failed = 0 - , transientErrors = 0 - , leaseSkipped = 0 - } - readIORef counter >>= \c -> c `shouldBe` 1 - Right recorded <- - Store.runStoreIO storeHandle $ - Store.readStreamForward (StreamName "wf:await-demo-ad-1") (StreamVersion 0) 10 - traverse (decodeRecorded workflowJournalCodec) (Vector.toList recorded) - `shouldSatisfy` \case - Right [StepRecorded "awk:approval" _ _, StepRecorded "use" _ _, WorkflowCompleted _] -> True - _ -> False - - -- M4: a discovered workflow whose name is absent from the registry is - -- skipped and counted, never silently dropped or fatal. - it "skips and counts a workflow whose name is absent from the registry" $ \storeHandle -> do - counter <- newIORef (0 :: Int) - let name = WorkflowName "orphan" - wid = WorkflowId "or-1" - crashed <- - try - ( Store.runStoreIO storeHandle $ - runWorkflow name wid (crashAfterStep1 counter) - ) :: - IO (Either SomeException (Either Store.StoreError (WorkflowOutcome (Int, Int, Int)))) - case crashed of - Left _ -> pure () - Right other -> expectationFailure ("expected a simulated crash, got " <> show other) - -- Empty registry: the orphan is surfaced via unknownName, not completed. - Right summary <- - Store.runStoreIO storeHandle $ resumeWorkflowsOnce defaultWorkflowResumeOptions Map.empty - summary - `shouldBe` ResumeSummary - { discovered = 1 - , resumed = 0 - , completed = 0 - , stillSuspended = 0 - , unknownName = 1 - , failed = 0 - , transientErrors = 0 - , leaseSkipped = 0 - } - -- The journal is unchanged: still one step, no completion. - Right recorded <- - Store.runStoreIO storeHandle $ - Store.readStreamForward (StreamName "wf:orphan-or-1") (StreamVersion 0) 10 - Vector.length recorded `shouldBe` 1 - - it "isolates a poison workflow so a healthy workflow still completes" $ \storeHandle -> do - healthyCounter <- newIORef (0 :: Int) - let poisonName = WorkflowName "poison" - poisonId = WorkflowId "poison-1" - healthyName = WorkflowName "healthy" - healthyId = WorkflowId "healthy-1" - opts = - defaultWorkflowResumeOptions - & #maxAttempts - .~ 1 - & #logEvent - .~ const (pure ()) - registry = - Map.fromList - [ (poisonName, WorkflowDef (\_ -> liftIO (throwIO SimulatedCrash) *> pure (0 :: Int))) - , (healthyName, WorkflowDef (\_ -> threeStep healthyCounter)) - ] - now <- getCurrentTime - Right () <- - Store.runStoreIO storeHandle $ - appendJournalEntry poisonName poisonId (StepRecorded "seed" (toJSON True) now) - crashed <- - try - ( Store.runStoreIO storeHandle $ - runWorkflow healthyName healthyId (crashAfterStep1 healthyCounter) - ) :: - IO (Either SomeException (Either Store.StoreError (WorkflowOutcome (Int, Int, Int)))) - case crashed of - Left _ -> pure () - Right other -> expectationFailure ("expected a simulated crash, got " <> show other) - Right summary <- Store.runStoreIO storeHandle $ resumeWorkflowsOnce opts registry - summary - `shouldBe` emptyResumeSummary - { discovered = 2 - , resumed = 2 - , completed = 1 - , failed = 1 - } - readIORef healthyCounter >>= \c -> c `shouldBe` 3 - Right (Just poisonRow) <- Store.runStoreIO storeHandle $ Instance.lookupInstance poisonName poisonId - poisonRow ^. #status `shouldBe` Instance.WfFailed - - it "marks a crashing workflow failed and short-circuits later direct runs" $ \storeHandle -> do - let name = WorkflowName "terminal-poison" - wid = WorkflowId "tp-1" - opts = - defaultWorkflowResumeOptions - & #maxAttempts - .~ 1 - & #logEvent - .~ const (pure ()) - registry = Map.singleton name (WorkflowDef (\_ -> liftIO (throwIO SimulatedCrash) *> pure (0 :: Int))) - now <- getCurrentTime - Right () <- - Store.runStoreIO storeHandle $ - appendJournalEntry name wid (StepRecorded "seed" (toJSON True) now) - Right summary <- Store.runStoreIO storeHandle $ resumeWorkflowsOnce opts registry - failed summary `shouldBe` 1 - Right (Just row) <- Store.runStoreIO storeHandle $ Instance.lookupInstance name wid - row ^. #status `shouldBe` Instance.WfFailed - row ^. #attempts `shouldBe` 1 - direct <- Store.runStoreIO storeHandle $ runWorkflow name wid (step (StepName "never") (pure (1 :: Int))) - direct `shouldBe` Right Failed - Right recordedFailed <- - Store.runStoreIO storeHandle $ - Store.readStreamForward (StreamName "wf:terminal-poison-tp-1") (StreamVersion 0) 10 - traverse (decodeRecorded workflowJournalCodec) (Vector.toList recordedFailed) - `shouldSatisfy` \case - Right events -> any (\case WorkflowFailed{} -> True; _ -> False) events - _ -> False - - it "resurrects a failed workflow and completes without rerunning its journaled prefix" $ \storeHandle -> do - shouldCrash <- newIORef True - counter <- newIORef (0 :: Int) - let name = WorkflowName "resurrect-complete" - wid = WorkflowId "rc-1" - opts = - defaultWorkflowResumeOptions - & #maxAttempts - .~ 1 - & #logEvent - .~ const (pure ()) - registry = Map.singleton name (WorkflowDef (\_ -> recoverableWorkflow shouldCrash counter)) - crashed <- - try - ( Store.runStoreIO storeHandle $ - runWorkflow name wid (recoverableWorkflow shouldCrash counter) - ) :: - IO (Either SomeException (Either Store.StoreError (WorkflowOutcome Int))) - case crashed of - Left _ -> pure () - Right other -> expectationFailure ("expected a simulated crash, got " <> show other) - readIORef counter `shouldReturn` 1 - - Right failedPass <- Store.runStoreIO storeHandle $ resumeWorkflowsOnce opts registry - failed failedPass `shouldBe` 1 - Right (Just failedRow) <- Store.runStoreIO storeHandle $ Instance.lookupInstance name wid - failedRow ^. #status `shouldBe` Instance.WfFailed - - writeIORef shouldCrash False - resurrected <- Store.runStoreIO storeHandle $ Instance.resurrectFailedWorkflow name wid - resurrected `shouldBe` Right Instance.WorkflowResurrected - Right (Just revivedRow) <- Store.runStoreIO storeHandle $ Instance.lookupInstance name wid - revivedRow ^. #status `shouldBe` Instance.WfRunning - revivedRow ^. #attempts `shouldBe` 0 - revivedRow ^. #lastError `shouldBe` Nothing - revivedRow ^. #nextAttemptAt `shouldBe` Nothing - - Right completedPass <- Store.runStoreIO storeHandle $ resumeWorkflowsOnce opts registry - completed completedPass `shouldBe` 1 - readIORef counter `shouldReturn` 2 - Right (Just completedRow) <- Store.runStoreIO storeHandle $ Instance.lookupInstance name wid - completedRow ^. #status `shouldBe` Instance.WfCompleted - - it "can fail again in the same generation after resurrection" $ \storeHandle -> do - shouldCrash <- newIORef True - counter <- newIORef (0 :: Int) - let name = WorkflowName "resurrect-refail" - wid = WorkflowId "rr-1" - opts = - defaultWorkflowResumeOptions - & #maxAttempts - .~ 1 - & #logEvent - .~ const (pure ()) - registry = Map.singleton name (WorkflowDef (\_ -> recoverableWorkflow shouldCrash counter)) - crashed <- - try - ( Store.runStoreIO storeHandle $ - runWorkflow name wid (recoverableWorkflow shouldCrash counter) - ) :: - IO (Either SomeException (Either Store.StoreError (WorkflowOutcome Int))) - case crashed of - Left _ -> pure () - Right other -> expectationFailure ("expected a simulated crash, got " <> show other) - - Right firstFailedPass <- Store.runStoreIO storeHandle $ resumeWorkflowsOnce opts registry - failed firstFailedPass `shouldBe` 1 - firstRevival <- Store.runStoreIO storeHandle $ Instance.resurrectFailedWorkflow name wid - firstRevival `shouldBe` Right Instance.WorkflowResurrected - Right secondFailedPass <- Store.runStoreIO storeHandle $ resumeWorkflowsOnce opts registry - failed secondFailedPass `shouldBe` 1 - Right (Just refailedRow) <- Store.runStoreIO storeHandle $ Instance.lookupInstance name wid - refailedRow ^. #status `shouldBe` Instance.WfFailed - - Right recorded <- - Store.runStoreIO storeHandle $ - Store.readStreamForward - (workflowGenerationStreamName name wid 0) - (StreamVersion 0) - 10 - let failureIds = - [ event ^. #eventId - | event <- Vector.toList recorded - , Right decoded <- [decodeRecorded workflowJournalCodec event] - , WorkflowFailed{} <- [decoded] - ] - case failureIds of - [firstFailureId, secondFailureId] -> - firstFailureId `shouldNotBe` secondFailureId - other -> - expectationFailure ("expected two failure events, got " <> show other) - - secondRevival <- Store.runStoreIO storeHandle $ Instance.resurrectFailedWorkflow name wid - secondRevival `shouldBe` Right Instance.WorkflowResurrected - - it "guards resurrection and revives a failed child link transactionally" $ \storeHandle -> do - let runningName = WorkflowName "resurrect-running" - runningId = WorkflowId "running-1" - missingName = WorkflowName "resurrect-missing" - missingId = WorkflowId "missing-1" - childName = WorkflowName "resurrect-child" - childId = WorkflowId "child-1" - now <- getCurrentTime - Right () <- - Store.runStoreIO storeHandle $ - appendJournalEntry runningName runningId (StepRecorded "seed" (toJSON True) now) - runningOutcome <- Store.runStoreIO storeHandle $ Instance.resurrectFailedWorkflow runningName runningId - runningOutcome `shouldBe` Right Instance.WorkflowNotFailed - missingOutcome <- Store.runStoreIO storeHandle $ Instance.resurrectFailedWorkflow missingName missingId - missingOutcome `shouldBe` Right Instance.WorkflowNotFound - - Right childMarkedFailed <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ do - Child.registerChildTx - "child-1" - "resurrect-child" - "parent-1" - "resurrect-parent" - "child:child-1:result" - Child.markChildFailedTx "child-1" "resurrect-child" "simulated terminal failure" - childMarkedFailed `shouldBe` True - Right () <- - Store.runStoreIO storeHandle $ - appendJournalEntry childName childId (WorkflowFailed "simulated terminal failure" now) - - childOutcome <- Store.runStoreIO storeHandle $ Instance.resurrectFailedWorkflow childName childId - childOutcome `shouldBe` Right Instance.WorkflowResurrected - Right (Just childRow) <- Store.runStoreIO storeHandle $ Child.lookupChild "child-1" "resurrect-child" - childRow ^. #status `shouldBe` Child.Running - childRow ^. #result `shouldBe` Nothing - childRow ^. #failureReason `shouldBe` Nothing - childRow ^. #completedAt `shouldBe` Nothing - - it "classifies thrown store errors as transient without consuming attempts" $ \storeHandle -> do - let name = WorkflowName "transient" - wid = WorkflowId "tr-1" - opts = defaultWorkflowResumeOptions & #logEvent .~ const (pure ()) - registry = - Map.singleton name $ - WorkflowDef - ( \_ -> do - _ <- throwError (Store.ConnectionLost "boom") - pure (0 :: Int) - ) - now <- getCurrentTime - Right () <- - Store.runStoreIO storeHandle $ - appendJournalEntry name wid (StepRecorded "seed" (toJSON True) now) - Right summary <- Store.runStoreIO storeHandle $ resumeWorkflowsOnce opts registry - transientErrors summary `shouldBe` 1 - failed summary `shouldBe` 0 - Right (Just row) <- Store.runStoreIO storeHandle $ Instance.lookupInstance name wid - row ^. #attempts `shouldBe` 0 - row ^. #status `shouldBe` Instance.WfRunning - - it "keeps the fixed-poll loop alive when one pass contains a poison workflow" $ \storeHandle -> do - done <- newEmptyMVar - healthyCounter <- newIORef (0 :: Int) - let poisonName = WorkflowName "fixed-loop-poison" - poisonId = WorkflowId "flp-1" - healthyName = WorkflowName "fixed-loop-healthy" - healthyId = WorkflowId "flh-1" - opts = - defaultWorkflowResumeOptions - & #pollInterval - .~ 50_000 - & #maxAttempts - .~ 1 - & #logEvent - .~ const (pure ()) - healthyBody = threeStepThenSignal healthyCounter done - registry = - Map.fromList - [ (poisonName, WorkflowDef (\_ -> liftIO (throwIO SimulatedCrash) *> pure (0 :: Int))) - , (healthyName, WorkflowDef (\_ -> healthyBody)) - ] - now <- getCurrentTime - Right () <- - Store.runStoreIO storeHandle $ - appendJournalEntry poisonName poisonId (StepRecorded "seed" (toJSON True) now) - crashed <- - try - ( Store.runStoreIO storeHandle $ - runWorkflow healthyName healthyId (crashAfterStep1 healthyCounter) - ) :: - IO (Either SomeException (Either Store.StoreError (WorkflowOutcome (Int, Int, Int)))) - case crashed of - Left _ -> pure () - Right other -> expectationFailure ("expected a simulated crash, got " <> show other) - worker <- forkIO (void (Store.runStoreIO storeHandle (runWorkflowResumeWorkerWith opts registry))) - completed <- timeout 5_000_000 (takeMVar done) - status <- threadStatus worker - killThread worker - completed `shouldBe` Just () - status `shouldSatisfy` \case - ThreadFinished -> False - ThreadDied -> False - _ -> True - - it "claims one workflow instance for a single live owner and releases it" $ \storeHandle -> do - let name = WorkflowName "lease-claim" - wid = WorkflowId "lc-1" - Right claimedA <- Store.runStoreIO storeHandle $ Instance.claimInstance "owner-a" 30 name wid - claimedA `shouldBe` True - Right claimedB <- Store.runStoreIO storeHandle $ Instance.claimInstance "owner-b" 30 name wid - claimedB `shouldBe` False - Right () <- Store.runStoreIO storeHandle $ Instance.releaseInstance "owner-a" False name wid - Right claimedBAfterRelease <- Store.runStoreIO storeHandle $ Instance.claimInstance "owner-b" 30 name wid - claimedBAfterRelease `shouldBe` True - - it "lets an expired workflow lease be taken and resets attempts on progressed release" $ \storeHandle -> do - let name = WorkflowName "lease-expire" - wid = WorkflowId "le-1" - Right claimedA <- Store.runStoreIO storeHandle $ Instance.claimInstance "owner-a" 30 name wid - claimedA `shouldBe` True - Right attempt <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ - Instance.recordCrashTx "le-1" "lease-expire" "boom" - attempt `shouldBe` 1 - Right () <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ - Tx.sql "UPDATE keiro.keiro_workflows SET lease_expires_at = now() - interval '1 second', next_attempt_at = now() - interval '1 second' WHERE workflow_id = 'le-1' AND workflow_name = 'lease-expire'" - Right claimedB <- Store.runStoreIO storeHandle $ Instance.claimInstance "owner-b" 30 name wid - claimedB `shouldBe` True - Right () <- Store.runStoreIO storeHandle $ Instance.releaseInstance "owner-b" True name wid - Right (Just row) <- Store.runStoreIO storeHandle $ Instance.lookupInstance name wid - row ^. #attempts `shouldBe` 0 - row ^. #lastError `shouldBe` Nothing - row ^. #nextAttemptAt `shouldBe` Nothing - row ^. #leasedBy `shouldBe` Nothing - - it "skips a resume candidate held by another live lease owner" $ \storeHandle -> do - ran <- newIORef False - let name = WorkflowName "lease-skip" - wid = WorkflowId "ls-1" - registry = - Map.singleton name $ - WorkflowDef - ( \_ -> do - liftIO (writeIORef ran True) - pure (0 :: Int) - ) - now <- getCurrentTime - Right () <- - Store.runStoreIO storeHandle $ - appendJournalEntry name wid (StepRecorded "seed" (toJSON True) now) - Right foreignClaim <- Store.runStoreIO storeHandle $ Instance.claimInstance "foreign-owner" 30 name wid - foreignClaim `shouldBe` True - Right summary <- Store.runStoreIO storeHandle $ resumeWorkflowsOnce defaultWorkflowResumeOptions registry - summary - `shouldBe` emptyResumeSummary - { discovered = 1 - , leaseSkipped = 1 - } - readIORef ran `shouldReturn` False - - -- M4: resume on an already-completed workflow is a genuine no-op. - it "discovers nothing for an already-completed workflow and is stable" $ \storeHandle -> do - counter <- newIORef (0 :: Int) - let name = WorkflowName "done-demo" - wid = WorkflowId "dd-1" - done <- Store.runStoreIO storeHandle $ runWorkflow name wid (threeStep counter) - done `shouldBe` Right (Completed (1, 2, 3)) - readIORef counter >>= \c -> c `shouldBe` 3 - let registry = Map.singleton name (WorkflowDef (\_wid -> threeStep counter)) - Right summary1 <- - Store.runStoreIO storeHandle $ resumeWorkflowsOnce defaultWorkflowResumeOptions registry - summary1 `shouldBe` emptyResumeSummary - Right summary2 <- - Store.runStoreIO storeHandle $ resumeWorkflowsOnce defaultWorkflowResumeOptions registry - summary2 `shouldBe` emptyResumeSummary - readIORef counter >>= \c -> c `shouldBe` 3 - - describe "Keiro.Workflow lease renewal" $ around (withFreshStore fixture) $ do - it "renews before a slow fresh step so the original lease cannot be stolen" $ \storeHandle -> do - attemptedClaim <- newIORef Nothing - let name = WorkflowName "lease-heartbeat" - wid = WorkflowId "heartbeat-1" - runOpts = - defaultWorkflowRunOptions - & #leaseHeartbeat - .~ Just LeaseHeartbeat{owner = "owner-a", ttl = 60} - body = - step (StepName "slow-boundary") $ do - liftIO (threadDelay 300_000) - claimed <- - Instance.claimInstance - "owner-b" - 60 - name - wid - liftIO (writeIORef attemptedClaim (Just claimed)) - pure claimed - Right claimedA <- Store.runStoreIO storeHandle $ Instance.claimInstance "owner-a" 0.2 name wid - claimedA `shouldBe` True - outcome <- Store.runStoreIO storeHandle $ runWorkflowWith runOpts name wid body - outcome `shouldBe` Right (Completed False) - readIORef attemptedClaim `shouldReturn` Just False - Right (Just row) <- Store.runStoreIO storeHandle $ Instance.lookupInstance name wid - row ^. #leasedBy `shouldBe` Just "owner-a" - - it "stops at a lost lease boundary and the resume worker records no crash" $ \storeHandle -> do - let directName = WorkflowName "lease-lost-direct" - directId = WorkflowId "lost-direct-1" - directOpts = - defaultWorkflowRunOptions - & #leaseHeartbeat - .~ Just LeaseHeartbeat{owner = "owner-a", ttl = 60} - now <- getCurrentTime - Right () <- - Store.runStoreIO storeHandle $ - appendJournalEntry directName directId (StepRecorded "seed" (toJSON True) now) - Right claimedA <- Store.runStoreIO storeHandle $ Instance.claimInstance "owner-a" 60 directName directId - claimedA `shouldBe` True - leaseUntil <- addUTCTime 60 <$> getCurrentTime - Right () <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ - Tx.statement - ("lost-direct-1", "lease-lost-direct", "owner-b", leaseUntil) - forceWorkflowLeaseStmt - firstDirectEffect <- newIORef (0 :: Int) - secondDirectEffect <- newIORef (0 :: Int) - direct <- - try - ( Store.runStoreIO storeHandle $ - runWorkflowWith directOpts directName directId $ do - _ <- step (StepName "first") (liftIO (incrementAndRead firstDirectEffect)) - step (StepName "second") (liftIO (incrementAndRead secondDirectEffect)) - ) :: - IO - ( Either - WorkflowLeaseLost - (Either Store.StoreError (WorkflowOutcome Int)) - ) - direct `shouldBe` Left WorkflowLeaseLost - readIORef firstDirectEffect `shouldReturn` 0 - readIORef secondDirectEffect `shouldReturn` 0 - directFinishedAt <- getCurrentTime - Right () <- - Store.runStoreIO storeHandle $ - appendJournalEntry directName directId (WorkflowCompleted directFinishedAt) - - firstWorkerEffect <- newIORef (0 :: Int) - secondWorkerEffect <- newIORef (0 :: Int) - let workerName = WorkflowName "lease-lost-worker" - workerId = WorkflowId "lost-worker-1" - workerOpts = - defaultWorkflowResumeOptions - & #logEvent - .~ const (pure ()) - registry = - Map.singleton workerName $ - WorkflowDef $ \_ -> do - _ <- - step (StepName "first") $ do - value <- liftIO (incrementAndRead firstWorkerEffect) - expires <- liftIO (addUTCTime 60 <$> getCurrentTime) - Store.runTransaction $ - Tx.statement - ("lost-worker-1", "lease-lost-worker", "owner-b", expires) - forceWorkflowLeaseStmt - pure value - step (StepName "second") (liftIO (incrementAndRead secondWorkerEffect)) - Right () <- - Store.runStoreIO storeHandle $ - appendJournalEntry workerName workerId (StepRecorded "seed" (toJSON True) now) - Right summary <- Store.runStoreIO storeHandle $ resumeWorkflowsOnce workerOpts registry - summary - `shouldBe` emptyResumeSummary - { discovered = 1 - , leaseSkipped = 1 - } - readIORef firstWorkerEffect `shouldReturn` 1 - readIORef secondWorkerEffect `shouldReturn` 0 - Right (Just row) <- Store.runStoreIO storeHandle $ Instance.lookupInstance workerName workerId - row ^. #attempts `shouldBe` 0 - row ^. #leasedBy `shouldBe` Just "owner-b" - - describe "Keiro.Workflow continue-as-new" $ around (withFreshStore fixture) $ do - -- EP-48 headline proof (Checks 1 & 2): a 300-step rolling-total workflow that - -- rotates every 50 steps keeps each physical generation journal bounded by - -- K = rotateEvery + 2 (at most rotateEvery work steps + the one seed step that - -- opened the generation + the one terminal marker), yet returns the correct - -- final total. A single non-rotating run would put all 300 steps on one - -- journal and the per-generation `<= K` bound would fail. - it "rotates a long workflow, bounds each generation, and returns the correct total" $ \storeHandle -> do - counter <- newIORef (0 :: Int) - let name = WorkflowName "roller" - wid = WorkflowId "r-1" - rotateEvery = 50 :: Int - total = 300 :: Int - k = rotateEvery + 2 - body = rollingTotal counter rotateEvery total - -- Re-invoke runWorkflow until it Completes; each call resolves and - -- advances the current generation, exactly as the resume worker does. - drive :: Int -> IO Int - drive budget - | budget <= 0 = - expectationFailure "workflow did not complete within the rotation budget" >> pure (-1) - | otherwise = do - outcome <- Store.runStoreIO storeHandle (runWorkflow name wid body) - case outcome of - Right ContinuedAsNew -> drive (budget - 1) - Right (Completed t) -> pure t - other -> expectationFailure ("unexpected outcome: " <> show other) >> pure (-1) - -- The first invocation rotates (generation 0 did rotateEvery steps). - firstOutcome <- Store.runStoreIO storeHandle (runWorkflow name wid body) - firstOutcome `shouldBe` Right ContinuedAsNew - -- Drive the remaining generations to completion (bounded passes). - finalTotal <- drive (total `div` rotateEvery + 3) - -- Check 2: correct result, and each side effect ran exactly once. - finalTotal `shouldBe` total - readIORef counter >>= (`shouldBe` total) - -- The workflow rotated to its final generation (300/50 = 6 generations: 0..5). - Right gen <- Store.runStoreIO storeHandle (currentGeneration name wid) - gen `shouldBe` (total `div` rotateEvery - 1) - -- Check 1: every generation's physical journal is bounded by K, and the - -- total is split ACROSS generations (bounded per generation, not in - -- aggregate). Each generation holds exactly 1 seed + rotateEvery work + 1 - -- marker = K events, so the sum is total + 2 per generation. - lengths <- - traverse - ( \g -> do - let streamName = workflowGenerationStreamName name wid g - Right evs <- Store.runStoreIO storeHandle (Store.readStreamForward streamName (StreamVersion 0) 1000) - pure (Vector.length evs) - ) - [0 .. gen] - for_ lengths (`shouldSatisfy` (<= k)) - sum lengths `shouldBe` (total + 2 * (gen + 1)) - -- The first generation ends with a rotation marker; the last with a - -- completion marker. - Right gen0evs <- Store.runStoreIO storeHandle (Store.readStreamForward (workflowGenerationStreamName name wid 0) (StreamVersion 0) 1000) - (decodeRecorded workflowJournalCodec <$> Vector.toList gen0evs) - `shouldSatisfy` any - ( \case - Right (WorkflowContinuedAsNew 1 _) -> True - _ -> False - ) - Right lastEvs <- Store.runStoreIO storeHandle (Store.readStreamForward (workflowGenerationStreamName name wid gen) (StreamVersion 0) 1000) - (decodeRecorded workflowJournalCodec <$> Vector.toList lastEvs) - `shouldSatisfy` any - ( \case - Right (WorkflowCompleted _) -> True - _ -> False - ) - - -- EP-48 Check 3: discovery and resume follow the CURRENT generation. After a - -- rotation the rotated (newer) generation is unfinished and discoverable — - -- the older generation's WorkflowContinuedAsNew marker does NOT mask it — and - -- the resume worker drives the rotated generation forward to completion. - it "rediscovers and resumes a rotated workflow on its current generation" $ \storeHandle -> do - counter <- newIORef (0 :: Int) - let name = WorkflowName "roller2" - wid = WorkflowId "r-2" - rotateEvery = 50 :: Int - total = 150 :: Int - registry = Map.singleton name (WorkflowDef (\_ -> rollingTotal counter rotateEvery total)) - resumeUntilDone :: Int -> IO () - resumeUntilDone budget - | budget <= 0 = expectationFailure "resume did not complete the rotated workflow" - | otherwise = do - Right summary <- - Store.runStoreIO storeHandle (resumeWorkflowsOnce defaultWorkflowResumeOptions registry) - if completed summary == 1 then pure () else resumeUntilDone (budget - 1) - -- First run rotates onto generation 1. - firstOutcome <- Store.runStoreIO storeHandle (runWorkflow name wid (rollingTotal counter rotateEvery total)) - firstOutcome `shouldBe` Right ContinuedAsNew - -- The rotated current generation (1) is unfinished and discoverable. - now <- getCurrentTime - Right unfinished <- Store.runStoreIO storeHandle (findUnfinishedWorkflowIds now) - unfinished `shouldBe` [("r-2", "roller2")] - -- The resume worker drives the rotated generation(s) to completion. - resumeUntilDone (total `div` rotateEvery + 3) - readIORef counter >>= (`shouldBe` total) - -- Finished: discovery now reports nothing for it. - finalNow <- getCurrentTime - Right finalUnfinished <- Store.runStoreIO storeHandle (findUnfinishedWorkflowIds finalNow) - finalUnfinished `shouldBe` [] - - describe "Keiro.Workflow patch API" $ around (withFreshStore fixture) $ do - it "an in-flight instance observes the OLD branch; a fresh instance the NEW branch; the decision is journaled once and stable" $ \storeHandle -> do - counter <- newIORef (0 :: Int) - let name = WorkflowName "patchwf" - inflight = WorkflowId "inflight-1" - fresh = WorkflowId "fresh-1" - patchOptions = defaultWorkflowRunOptions & #activePatches .~ Set.singleton fraudPatchId - - -- 1. Run the in-flight instance to a suspension under the PRE-patch code. - pre <- Store.runStoreIO storeHandle $ runWorkflow name inflight (prePatchWorkflow counter) - pre `shouldBe` Right Suspended - - -- 2. Redeploy: re-run the SAME instance id under the POST-patch code. It - -- already journaled reserve-inventory, so it is in flight -> False. - r1 <- Store.runStoreIO storeHandle $ runWorkflowWith patchOptions name inflight (postPatchWorkflow counter) - r1 `shouldBe` Right (Completed "old-branch") - - -- 3. Replay the in-flight instance again: same OLD branch, every time. - r2 <- Store.runStoreIO storeHandle $ runWorkflowWith patchOptions name inflight (postPatchWorkflow counter) - r2 `shouldBe` Right (Completed "old-branch") - - -- 4. A fresh instance under the POST-patch code takes the NEW branch. - f1 <- Store.runStoreIO storeHandle $ runWorkflowWith patchOptions name fresh (postPatchWorkflow counter) - f1 `shouldBe` Right (Completed "new-branch") - -- and stays on the new branch on replay. - f2 <- Store.runStoreIO storeHandle $ runWorkflowWith patchOptions name fresh (postPatchWorkflow counter) - f2 `shouldBe` Right (Completed "new-branch") - - -- 5. The patch decision is journaled exactly once per instance, with the - -- expected Bool, on the patch: key. - Right inflightJournal <- - Store.runStoreIO storeHandle $ - Store.readStreamForward (StreamName "wf:patchwf-inflight-1") (StreamVersion 0) 20 - let inflightDecisions = - [ v - | Right ev <- map (decodeRecorded workflowJournalCodec) (Vector.toList inflightJournal) - , StepRecorded k v _ <- [ev] - , k == patchStepName fraudPatchId - ] - inflightDecisions `shouldBe` [toJSON False] - - Right freshJournal <- - Store.runStoreIO storeHandle $ - Store.readStreamForward (StreamName "wf:patchwf-fresh-1") (StreamVersion 0) 20 - let freshDecisions = - [ v - | Right ev <- map (decodeRecorded workflowJournalCodec) (Vector.toList freshJournal) - , StepRecorded k v _ <- [ev] - , k == patchStepName fraudPatchId - ] - freshDecisions `shouldBe` [toJSON True] - let freshPatchSets = - [ v - | Right ev <- map (decodeRecorded workflowJournalCodec) (Vector.toList freshJournal) - , StepRecorded k v _ <- [ev] - , k == patchSetStepName - ] - freshPatchSets `shouldBe` [toJSON [unPatchId fraudPatchId]] - - it "a fresh instance suspended before its patch call still takes the NEW branch" $ \storeHandle -> do - counter <- newIORef (0 :: Int) - let name = WorkflowName "patch-after-suspend" - wid = WorkflowId "pas-1" - patchOptions = defaultWorkflowRunOptions & #activePatches .~ Set.singleton fraudPatchId - Right Suspended <- - Store.runStoreIO storeHandle $ - runWorkflowWith patchOptions name wid (postPatchAfterSuspendWorkflow counter) - now <- getCurrentTime - Right () <- - Store.runStoreIO storeHandle $ - appendJournalEntry name wid (StepRecorded "awk:gate" Aeson.Null now) - resumed <- - Store.runStoreIO storeHandle $ - runWorkflowWith patchOptions name wid (postPatchAfterSuspendWorkflow counter) - resumed `shouldBe` Right (Completed "new-branch") - - it "an in-flight instance with only wake-source completions stays on the OLD branch" $ \storeHandle -> do - let name = WorkflowName "patch-wake-only" - wid = WorkflowId "pwo-1" - patchOptions = defaultWorkflowRunOptions & #activePatches .~ Set.singleton fraudPatchId - Right Suspended <- Store.runStoreIO storeHandle $ runWorkflow name wid prePatchWakeOnlyWorkflow - now <- getCurrentTime - Right () <- - Store.runStoreIO storeHandle $ - appendJournalEntry name wid (StepRecorded "awk:gate" Aeson.Null now) - resumed <- - Store.runStoreIO storeHandle $ - runWorkflowWith patchOptions name wid postPatchWakeOnlyWorkflow - resumed `shouldBe` Right (Completed "old-branch") - - it "records the active patch set again for a fresh rotated generation" $ \storeHandle -> do - let name = WorkflowName "patch-rotating" - wid = WorkflowId "pr-1" - patchOptions = defaultWorkflowRunOptions & #activePatches .~ Set.singleton fraudPatchId - first <- Store.runStoreIO storeHandle $ runWorkflowWith patchOptions name wid rotatingPatchWorkflow - first `shouldBe` Right ContinuedAsNew - second <- Store.runStoreIO storeHandle $ runWorkflowWith patchOptions name wid rotatingPatchWorkflow - second `shouldBe` Right (Completed "new-branch") - Right gen1Journal <- - Store.runStoreIO storeHandle $ - Store.readStreamForward (workflowGenerationStreamName name wid 1) (StreamVersion 0) 20 - let gen1PatchSets = - [ v - | Right ev <- map (decodeRecorded workflowJournalCodec) (Vector.toList gen1Journal) - , StepRecorded k v _ <- [ev] - , k == patchSetStepName - ] - gen1PatchSets `shouldBe` [toJSON [unPatchId fraudPatchId]] - - describe "Keiro.Workflow patch recording at rotation" $ around (withFreshStore fixture) $ do - it "keeps the active patch after a wake append lands before the first rotated run" $ \storeHandle -> do - let name = WorkflowName "patch-rotation-race" - wid = WorkflowId "prr-1" - patchOptions = - defaultWorkflowRunOptions - & #activePatches - .~ Set.singleton fraudPatchId - generationOneStream = workflowGenerationStreamName name wid 1 - - first <- - Store.runStoreIO storeHandle $ - runWorkflowWith patchOptions name wid rotatingPatchWorkflow - first `shouldBe` Right ContinuedAsNew - Right patchSetRecorded <- - Store.runStoreIO storeHandle $ - stepExists name wid 1 patchSetStepName - patchSetRecorded `shouldBe` True - - now <- getCurrentTime - Right () <- - Store.runStoreIO storeHandle $ - appendJournalEntry - name - wid - ( StepRecorded - "awk:11111111-1111-1111-1111-111111111111" - (toJSON True) - now - ) - - second <- - Store.runStoreIO storeHandle $ - runWorkflowWith patchOptions name wid rotatingPatchWorkflow - second `shouldBe` Right (Completed "new-branch") - replayed <- - Store.runStoreIO storeHandle $ - runWorkflowWith patchOptions name wid rotatingPatchWorkflow - replayed `shouldBe` Right (Completed "new-branch") - - Right generationOneJournal <- - Store.runStoreIO storeHandle $ - Store.readStreamForward generationOneStream (StreamVersion 0) 20 - let decoded = - map (decodeRecorded workflowJournalCodec) (Vector.toList generationOneJournal) - patchSets = - [ value - | Right (StepRecorded key value _) <- decoded - , key == patchSetStepName - ] - decisions = - [ value - | Right (StepRecorded key value _) <- decoded - , key == patchStepName fraudPatchId - ] - patchSets `shouldBe` [toJSON [unPatchId fraudPatchId]] - decisions `shouldBe` [toJSON True] - - describe "Keiro.Wake" $ around (withFreshStore fixture) $ do - -- EP-50: the wake primitive over kiroku's existing per-store notifier. - it "returns WokenByTimeout when idle (no append)" $ \store -> do - wake <- wakeSignalFromStore store - reason <- waitForWake wake 200000 -- 200 ms - reason `shouldBe` WokenByTimeout - - it "returns WokenByNotify promptly after a real append" $ \store -> do - wake <- wakeSignalFromStore store - -- A real append bumps the streams row and fires kiroku's NOTIFY on - -- kiroku.events; the store's notifier ticks the broadcast channel. - now <- getCurrentTime - Right () <- - Store.runStoreIO store $ - appendJournalEntry (WorkflowName "wakedemo") (WorkflowId "w1") (StepRecorded "s" (toJSON True) now) - reason <- waitForWake wake 5000000 -- generous 5 s ceiling; the round-trip is milliseconds - reason `shouldBe` WokenByNotify - - it "neverWake always returns WokenByTimeout" $ \_store -> do - reason <- waitForWake neverWake 100000 - reason `shouldBe` WokenByTimeout - - describe "Keiro.Workflow push latency (EP-50)" $ around (withFreshStore fixture) $ do - -- The user-visible win: a gated workflow resumes within sub-second of the - -- gate append, under a deliberately large (10 s) fallback — so a pass that - -- resumes it sub-second can only have been woken by the NOTIFY, not the poll. - it "resumes a gated workflow sub-second after the gate append (10s fallback)" $ \store -> do - done <- newEmptyMVar - let name = WorkflowName "pushwf" - wid = WorkflowId "p-1" - registry = Map.singleton name (WorkflowDef (\_ -> gateThenSignal done)) - opts = defaultWorkflowResumeOptions & #pollInterval .~ 10000000 -- 10 s fallback - first <- Store.runStoreIO store (runWorkflow name wid (gateThenSignal done)) - first `shouldBe` Right Suspended - worker <- forkIO (runWorkflowResumeWorkerPush store opts registry) - -- Let the worker start, duplicate the tick channel, and park in its wait - -- before we append, so the gate's NOTIFY cannot be missed. - threadDelay 250000 - now <- getCurrentTime - Right () <- - Store.runStoreIO store $ - appendJournalEntry name wid (StepRecorded "awk:gate" (toJSON ()) now) - resumed <- timeout 5000000 (takeMVar done) - t1 <- getCurrentTime - killThread worker - resumed `shouldBe` Just () - let latency = realToFrac (diffUTCTime t1 now) :: Double - latency `shouldSatisfy` (< 1.0) - - it "logs a failed push pass and keeps draining after the store recovers" $ \store -> do - done <- newEmptyMVar - logs <- newIORef [] - let name = WorkflowName "push-recover" - wid = WorkflowId "pr-1" - registry = Map.singleton name (WorkflowDef (\_ -> gateThenSignal done)) - opts = - defaultWorkflowResumeOptions - & #pollInterval - .~ 100_000 - & #logEvent - .~ \event -> modifyIORef' logs (<> [event]) - waitForPassFailure = timeout 5_000_000 $ do - let go = do - seen <- readIORef logs - if any isPassFailure seen - then pure () - else threadDelay 20_000 >> go - go - isPassFailure = \case - ResumePassFailed{} -> True - _ -> False - first <- Store.runStoreIO store (runWorkflow name wid (gateThenSignal done)) - first `shouldBe` Right Suspended - Right () <- - Store.runStoreIO store $ - Store.runTransaction $ - Tx.sql "ALTER TABLE keiro.keiro_workflow_steps RENAME TO keiro_workflow_steps_hidden" - worker <- forkIO (runWorkflowResumeWorkerPush store opts registry) - logged <- waitForPassFailure - logged `shouldBe` Just () - Right () <- - Store.runStoreIO store $ - Store.runTransaction $ - Tx.sql "ALTER TABLE keiro.keiro_workflow_steps_hidden RENAME TO keiro_workflow_steps" - now <- getCurrentTime - Right () <- - Store.runStoreIO store $ - appendJournalEntry name wid (StepRecorded "awk:gate" (toJSON ()) now) - resumed <- timeout 5_000_000 (takeMVar done) - status <- threadStatus worker - killThread worker - resumed `shouldBe` Just () - status `shouldSatisfy` \case - ThreadFinished -> False - ThreadDied -> False - _ -> True - - describe "Keiro.Workflow push fallback (EP-50)" $ around (withFreshStore fixture) $ do - -- Push is strictly an optimization: with the worker on 'neverWake' (every - -- NOTIFY dropped) and a small fallback, the gated workflow still drains on - -- the durable poll. - it "still drains on the fallback timeout when no notification is delivered" $ \store -> do - done <- newEmptyMVar - let name = WorkflowName "fallbackwf" - wid = WorkflowId "f-1" - registry = Map.singleton name (WorkflowDef (\_ -> gateThenSignal done)) - onePass = void (Store.runStoreIO store (resumeWorkflowsOnce defaultWorkflowResumeOptions registry)) - first <- Store.runStoreIO store (runWorkflow name wid (gateThenSignal done)) - first `shouldBe` Right Suspended - worker <- forkIO (runPollLoopWith neverWake 200000 onePass) -- 200 ms fallback, no notifications - now <- getCurrentTime - Right () <- - Store.runStoreIO store $ - appendJournalEntry name wid (StepRecorded "awk:gate" (toJSON ()) now) - resumed <- timeout 5000000 (takeMVar done) - killThread worker - resumed `shouldBe` Just () - - describe "Shard lease" $ around (withFreshStore fixture) $ do - -- EP-51 M2: claim / renew / release / expiry at the SQL layer, with explicit - -- `now` timestamps standing in for the passage of time (no workers yet). The - -- exclusion guarantee is the FOR UPDATE SKIP LOCKED claim; disjointness and - -- failover are both observable purely from the lease table. - let subName = SubscriptionName "orders-shard" - wA = WorkerId sampleUuid - wB = WorkerId sampleUuid2 - ttl = 30 :: NominalDiffTime - t0 = UTCTime (ModifiedJulianDay 60000) (secondsToDiffTime 0) - tExpired = addUTCTime 60 t0 -- past A's 30 s lease - shardOpts = defaultShardedWorkerOptions (Category (CategoryName "orders")) 4 - it "validates sharded worker options before startup" $ \_store -> do - shouldBeRight_ (mkShardedWorkerOptions shardOpts) - mkShardedWorkerOptions (shardOpts & #shardCount .~ 0) - `shouldBeLeft` InvalidShardCount 0 - mkShardedWorkerOptions (shardOpts & #leaseTtl .~ 0) - `shouldBeLeft` InvalidShardLeaseTtl 0 - mkShardedWorkerOptions (shardOpts & #renewInterval .~ 0) - `shouldBeLeft` InvalidShardRenewInterval 0 - mkShardedWorkerOptions (shardOpts & #leaseTtl .~ 10 & #renewInterval .~ 10) - `shouldBeLeft` InvalidShardLeaseRenewInterval 10 10 - mkShardedWorkerOptions (shardOpts & #batchSize .~ 0) - `shouldBeLeft` InvalidShardBatchSize 0 - mkShardedWorkerOptions (shardOpts & #bufferSize .~ 0) - `shouldBeLeft` InvalidShardBufferSize 0 - mkShardedWorkerOptions (shardOpts & #handlerRetryDelay .~ KirokuSub.RetryDelay (-1)) - `shouldBeLeft` InvalidShardHandlerRetryDelay (KirokuSub.RetryDelay (-1)) - mkShardedWorkerOptions (shardOpts & #retryPolicy .~ KirokuSub.RetryPolicy 0) - `shouldBeLeft` InvalidShardRetryMaxAttempts 0 - - it "ensureShardRows populates N rows once (idempotent on re-run)" $ \store -> do - Right () <- Store.runStoreIO store $ Store.runTransaction $ do - ensureShardRows subName 4 - ensureShardRows subName 4 - Right rows <- Store.runStoreIO store $ Store.runTransaction (listShardOwnership subName) - map (\(b, _, _) -> b) rows `shouldBe` [0, 1, 2, 3] - all (\(_, o, _) -> isNothing o) rows `shouldBe` True - - it "worker A claims all N when free; B claims 0 while A holds valid leases" $ \store -> do - Right claimedA <- Store.runStoreIO store $ Store.runTransaction $ do - ensureShardRows subName 4 - claimShardsTx subName wA 4 t0 ttl - claimedA `shouldBe` [0, 1, 2, 3] - Right claimedB <- Store.runStoreIO store $ Store.runTransaction (claimShardsTx subName wB 4 t0 ttl) - claimedB `shouldBe` [] - - it "B claims A's buckets after A's lease expires; A then renews nothing" $ \store -> do - Right _ <- Store.runStoreIO store $ Store.runTransaction $ do - ensureShardRows subName 4 - claimShardsTx subName wA 4 t0 ttl - Right claimedB <- Store.runStoreIO store $ Store.runTransaction (claimShardsTx subName wB 4 tExpired ttl) - claimedB `shouldBe` [0, 1, 2, 3] - -- A lost every bucket to B, so its renew returns the empty set: this is how - -- a worker learns it no longer owns a bucket and stops reading it. - Right heldA <- Store.runStoreIO store $ Store.runTransaction (renewLeaseTx subName wA tExpired ttl) - heldA `shouldBe` [] - - it "renewLease returns only still-held buckets" $ \store -> do - Right held <- Store.runStoreIO store $ Store.runTransaction $ do - ensureShardRows subName 4 - _ <- claimShardsTx subName wA 4 t0 ttl - renewLeaseTx subName wA t0 ttl - held `shouldBe` [0, 1, 2, 3] - - it "releaseShards: relinquished buckets are immediately claimable" $ \store -> do - Right _ <- Store.runStoreIO store $ Store.runTransaction $ do - ensureShardRows subName 4 - _ <- claimShardsTx subName wA 4 t0 ttl - releaseShardsTx subName wA [0, 1] - -- Even while A's lease over 2,3 is still valid, the released 0,1 are claimable. - Right claimedB <- Store.runStoreIO store $ Store.runTransaction (claimShardsTx subName wB 4 t0 ttl) - claimedB `shouldBe` [0, 1] - - it "fairShareTarget divides buckets evenly (ceil)" $ \_store -> do - fairShareTarget 6 3 `shouldBe` 2 - fairShareTarget 6 4 `shouldBe` 2 - fairShareTarget 7 3 `shouldBe` 3 - fairShareTarget 4 0 `shouldBe` 4 -- a non-positive estimate claims everything - it "acquireOutcome keeps previous ownership on acquire failure" $ \_store -> do - let previous = Set.fromList [0, 2] - acquireOutcome previous (Left "database unavailable") - `shouldBe` (previous, Just (ShardAcquireFailed "database unavailable")) - acquireOutcome previous (Right (Set.fromList [1, 3])) - `shouldBe` (Set.fromList [1, 3], Nothing) - - it "ensureShards rejects a shardCount mismatch" $ \store -> do - let lease4 = - ShardLease - { subscriptionName = subName - , workerId = wA - , shardCount = 4 - , leaseTtl = ttl - } - lease6 = - ShardLease - { subscriptionName = subName - , workerId = wA - , shardCount = 6 - , leaseTtl = ttl - } - Right () <- Store.runStoreIO store (ensureShards lease4) - Store.runStoreIO store (ensureShards lease6) - `shouldThrow` \case - ShardCountMismatch name configured found -> - name == "orders-shard" && configured == 6 && found == [4] - - describe "Sharded subscription single worker" $ around (withFreshStore fixture) $ do - -- EP-51 M3: one process owning all N buckets drains a seeded category exactly - -- once. The sink is idempotent on event_id, so "count == total" proves every - -- event was delivered with none missing and none surviving as a duplicate row. - it "one worker with N=4 buckets drains a seeded category exactly once" $ \store -> do - Right () <- Store.runStoreIO store $ Store.runTransaction (Tx.sql createShardSinkSql) - total <- seedOrders store 8 5 -- 40 events across 8 streams - let opts = - (defaultShardedWorkerOptions (Category (CategoryName "orders")) 4) - { leaseTtl = 3 - , renewInterval = 0.3 - } - w <- forkIO (runShardedSubscriptionGroup store (SubscriptionName "orders-sub") opts (sinkHandler store 1)) - drained <- waitUntilSinkCount store total 20_000_000 - killThread w - drained `shouldBe` True - count <- shardSinkCount store - count `shouldBe` total - maxW <- maxWorkersPerStream store - maxW `shouldBe` 1 - - describe "Sharded subscription drain and failover" $ around (withFreshStore fixture) $ do - -- EP-51 M5: the behavioural acceptance. Three worker processes cooperatively - -- partition a category; we let ownership converge on the *empty* category - -- first (so the churn of cold-start rebalancing touches no events), then seed - -- and drain under stable membership — so each stream is owned by exactly one - -- worker throughout the drain. Then we kill a worker and prove its buckets are - -- re-homed and the new events drain (failover via lease expiry). - let sub = SubscriptionName "orders-failover" - mkOpts = (defaultShardedWorkerOptions (Category (CategoryName "orders")) 6){leaseTtl = 3, renewInterval = 0.3} - it "three workers drain disjointly, then re-home a killed worker's buckets" $ \store -> do - Right () <- Store.runStoreIO store $ Store.runTransaction (Tx.sql createShardSinkSql) - w1 <- forkIO (runShardedSubscriptionGroup store sub mkOpts (sinkHandler store 1)) - w2 <- forkIO (runShardedSubscriptionGroup store sub mkOpts (sinkHandler store 2)) - w3 <- forkIO (runShardedSubscriptionGroup store sub mkOpts (sinkHandler store 3)) - -- Wait for cooperative balance on the empty category: all 6 buckets owned, - -- spread across >= 2 workers, none holding more than its fair share. - balanced <- waitShardsBalanced store sub 6 2 15_000_000 - balanced `shouldBe` True - -- Now seed and drain under stable membership. - total1 <- seedOrders store 12 5 -- 60 events - ok1 <- waitUntilSinkCount store total1 25_000_000 - ok1 `shouldBe` True - -- Disjoint: no stream key was processed by two workers (stable membership, - -- so no re-homing split any stream). - maxW <- maxWorkersPerStream store - maxW `shouldBe` 1 - -- The work genuinely spread (not a monopoly): at least two workers participated. - spread <- distinctWorkers store - spread `shouldSatisfy` (>= 2) - -- Counts sum to total with no duplicate event id (PK on event_id + count). - c1 <- shardSinkCount store - c1 `shouldBe` total1 - -- Kill worker 1 (its readers stop; it stops renewing, so its leases expire). - killThread w1 - -- Seed more across all streams; some hash to worker 1's now-orphaned buckets. - total2 <- seedOrders store 12 5 -- another 60 - -- Failover: a surviving worker re-claims the expired buckets and drains the - -- new events. If re-homing did not happen, events on worker 1's buckets would - -- never drain and this would time out. - ok2 <- waitUntilSinkCount store (total1 + total2) 30_000_000 - killThread w2 - killThread w3 - ok2 `shouldBe` True - c2 <- shardSinkCount store - c2 `shouldBe` (total1 + total2) - - it "a killed worker relinquishes its leases immediately" $ \store -> do - let subImmediate = SubscriptionName "orders-immediate-release" - longTtlOpts = - (defaultShardedWorkerOptions (Category (CategoryName "orders")) 4) - { leaseTtl = 30 - , renewInterval = 0.2 - } - w <- forkIO (runShardedSubscriptionGroup store subImmediate longTtlOpts (sinkHandler store 1)) - owned <- waitShardsBalanced store subImmediate 4 1 10_000_000 - owned `shouldBe` True - killThread w - released <- waitShardsUnowned store subImmediate 4 3_000_000 - released `shouldBe` True - - it "a handler exception is retried in place and drains" $ \store -> do - Right () <- Store.runStoreIO store $ Store.runTransaction (Tx.sql createShardSinkSql) - thrown <- newIORef False - errors <- newIORef [] - let subRestart = SubscriptionName "orders-reader-restart" - opts = - (defaultShardedWorkerOptions (Category (CategoryName "orders")) 2) - { leaseTtl = 3 - , renewInterval = 0.2 - , handlerRetryDelay = KirokuSub.RetryDelay 0.05 - , onShardError = Just (\err -> modifyIORef' errors (err :)) - } - handler ev = do - firstTime <- - atomicModifyIORef' - thrown - ( \seen -> - if seen - then (seen, False) - else (True, True) - ) - when firstTime (throwIO (userError "reader boom")) - sinkHandler store 1 ev - w <- forkIO (runShardedSubscriptionGroup store subRestart opts handler) - balanced <- waitShardsBalanced store subRestart 2 1 10_000_000 - balanced `shouldBe` True - total <- seedOrders store 4 2 - drained <- waitUntilSinkCount store total 20_000_000 - killThread w - drained `shouldBe` True - seenErrors <- readIORef errors - seenErrors `shouldSatisfy` all (\case ShardReaderDied _ _ -> False; _ -> True) - - describe "Sharded subscription ack coupling" $ around (withFreshStore fixture) $ do - it "redelivers a batch-tail event whose handler was killed mid-flight" $ \store -> do - Right () <- Store.runStoreIO store $ Store.runTransaction (Tx.sql createShardSinkSql) - total <- seedOrders store 1 5 - enteredTail <- newEmptyMVar - holdTail <- newEmptyMVar - let sub = SubscriptionName "orders-ack-tail" - opts = - (defaultShardedWorkerOptions (Category (CategoryName "orders")) 1) - { leaseTtl = 3 - , renewInterval = 0.3 - } - blockingHandler ev = do - let orderNumber = parseEither (withObject "OrderPlaced" (.: "n")) (ev ^. #payload) - when (orderNumber == Right (4 :: Int)) $ do - putMVar enteredTail () - takeMVar holdTail - sinkHandler store 1 ev - first <- forkIO (runShardedSubscriptionGroup store sub opts blockingHandler) - entered <- timeout 10_000_000 (takeMVar enteredTail) - entered `shouldBe` Just () - -- The old pull bridge replies Continue before invoking the handler; - -- leave enough time for its batch-tail checkpoint to commit while the - -- handler remains blocked. The ack-coupled bridge introduced by EP-96 - -- remains blocked on the unfilled reply instead. - threadDelay 200_000 - killThread first - second <- forkIO (runShardedSubscriptionGroup store sub opts (sinkHandler store 2)) - drained <- waitUntilSinkCount store total 20_000_000 - killThread second - drained `shouldBe` True - shardSinkCount store `shouldReturn` total - - it "loses no events when a bucket is shed mid-drain during rebalance" $ \store -> do - Right () <- Store.runStoreIO store $ Store.runTransaction (Tx.sql createShardSinkSql) - total <- seedOrders store 24 5 - let sub = SubscriptionName "orders-ack-rebalance" - opts = - (defaultShardedWorkerOptions (Category (CategoryName "orders")) 4) - { leaseTtl = 3 - , renewInterval = 0.3 - , batchSize = 1 - } - slowHandler tag ev = do - threadDelay 100_000 - sinkHandler store tag ev - first <- forkIO (runShardedSubscriptionGroup store sub opts (slowHandler 1)) - -- acquireOwnedBuckets claims one bucket per pass. Starting the joiner - -- while A owns three leaves one claimable bucket for B, making B visible; - -- A's next pass then sheds its excess third bucket while its handler is - -- deliberately slow and in flight. - ownsThree <- waitUntilOwnedShardCount store sub 3 10_000_000 - ownsThree `shouldBe` True - second <- forkIO (runShardedSubscriptionGroup store sub opts (slowHandler 2)) - drained <- waitUntilSinkCount store total 30_000_000 - killThread first - killThread second - drained `shouldBe` True - shardSinkCount store `shouldReturn` total - - it "allows zombie overlap duplicates without losing an event" $ \store -> do - Right () <- Store.runStoreIO store $ Store.runTransaction (Tx.sql createShardSinkSql) - total <- seedOrders store 1 5 - entered <- newEmptyMVar - release <- newEmptyMVar - deliveries <- newIORef ([] :: [EventId]) - successor <- newIORef Nothing - readersA <- newIORef Map.empty - let sub = SubscriptionName "orders-ack-zombie" - opts = - (defaultShardedWorkerOptions (Category (CategoryName "orders")) 1) - { leaseTtl = 2 - , renewInterval = 0.2 - } - leaseA = - ShardLease - { subscriptionName = sub - , workerId = WorkerId sampleUuid - , shardCount = 1 - , leaseTtl = 2 - } - handlerA delivery = do - let ev = delivery ^. #event - modifyIORef' deliveries ((ev ^. #eventId) :) - putMVar entered () - takeMVar release - sinkHandler store 1 ev - pure ShardAckOk - handlerB delivery = do - let ev = delivery ^. #event - modifyIORef' deliveries ((ev ^. #eventId) :) - sinkHandler store 2 ev - pure ShardAckOk - cleanup = do - void (tryPutMVar release ()) - mSuccessor <- readIORef successor - for_ mSuccessor killThread - now <- getCurrentTime - let cleanupWorker = WorkerId sampleUuid2 - _ <- Store.runStoreIO store $ Store.runTransaction $ do - releaseShardsTx sub (WorkerId sampleUuid) [0] - claimShardsTx sub cleanupWorker 1 now 30 - void (reconcileShardsOnce store leaseA opts readersA handlerA) - ( do - Right () <- Store.runStoreIO store (ensureShards leaseA) - void (reconcileShardsOnce store leaseA opts readersA handlerA) - timeout 10_000_000 (takeMVar entered) `shouldReturn` Just () - -- A no longer renews, but its reader remains alive and blocked - -- with one unacknowledged event. B can claim after expiry and - -- must therefore receive that event again from the checkpoint. - threadDelay 2_500_000 - workerB <- forkIO (runShardedSubscriptionGroupAck store sub opts handlerB) - writeIORef successor (Just workerB) - drained <- waitUntilSinkCount store total 20_000_000 - drained `shouldBe` True - raw <- readIORef deliveries - length raw `shouldSatisfy` (> total) - shardSinkCount store `shouldReturn` total - ) - `finally` cleanup - - it "dead-letters a poison event after bounded retries and keeps draining" $ \store -> do - Right () <- Store.runStoreIO store $ Store.runTransaction (Tx.sql createShardSinkSql) - total <- seedOrders store 1 4 - poisonDeliveries <- newIORef (0 :: Int) - errors <- newIORef [] - let sub = SubscriptionName "orders-ack-poison" - opts = - (defaultShardedWorkerOptions (Category (CategoryName "orders")) 1) - { leaseTtl = 3 - , renewInterval = 0.2 - , handlerRetryDelay = KirokuSub.RetryDelay 0.05 - , retryPolicy = KirokuSub.RetryPolicy 3 - , onShardError = Just (\err -> modifyIORef' errors (err :)) - } - handler ev = do - let orderNumber = parseEither (withObject "OrderPlaced" (.: "n")) (ev ^. #payload) - if orderNumber == Right (1 :: Int) - then do - modifyIORef' poisonDeliveries (+ 1) - throwIO (userError "poison order") - else sinkHandler store 1 ev - worker <- forkIO (runShardedSubscriptionGroup store sub opts handler) - drained <- waitUntilSinkCount store (total - 1) 20_000_000 - details <- shardDeadLetterDetails store "orders-ack-poison" - attempts <- readIORef poisonDeliveries - seenErrors <- readIORef errors - killThread worker - drained `shouldBe` True - attempts `shouldBe` 3 - details `shouldBe` (1, Just "max retry attempts exceeded (3)", Just 3) - seenErrors `shouldSatisfy` all (\case ShardReaderDied _ _ -> False; _ -> True) - - describe "Keiro.Workflow observability" $ around (withFreshStore fixture) $ do - -- The headline operability signal: executed (real work) vs replayed - -- (recorded history), recorded by the runtime through an SDK meter and read - -- back from the in-memory exporter — plus the active gauge and the - -- journal-length histogram. - it "records workflow instruments through an SDK meter" $ \storeHandle -> do - (exporter, ref) <- inMemoryMetricExporter - (provider, _env) <- - createMeterProvider - emptyMaterializedResources - defaultSdkMeterProviderOptions{metricExporter = Just exporter} - meter <- getMeter provider Telemetry.keiroInstrumentationLibrary - metrics <- Telemetry.newKeiroMetrics meter - counter <- newIORef (0 :: Int) - let name = WorkflowName "obs" - wid = WorkflowId "obs-1" - opts = defaultWorkflowRunOptions & #metrics .~ Just metrics - -- First run: both steps miss → two executions. - first <- Store.runStoreIO storeHandle $ runWorkflowWith opts name wid (demoWorkflow counter) - first `shouldBe` Right (Completed (1, 2)) - -- Second run, same id: both steps hit → two replays. - second <- Store.runStoreIO storeHandle $ runWorkflowWith opts name wid (demoWorkflow counter) - second `shouldBe` Right (Completed (1, 2)) - -- The side effects ran exactly twice across both runs (the replay run - -- short-circuited every step). - readIORef counter >>= \c -> c `shouldBe` 2 - _ <- forceFlushMeterProvider provider Nothing - exported <- readIORef ref - let scalars = flattenScalarPoints exported - hists = flattenHistogramPoints exported - lookup "keiro.workflow.steps.executed" scalars `shouldBe` Just (IntNumber 2) - lookup "keiro.workflow.steps.replayed" scalars `shouldBe` Just (IntNumber 2) - -- One journal-length observation per completed run (two completions). - [c | (n, c, _) <- hists, n == "keiro.workflow.journal.length"] `shouldBe` [2] - -- Both runs finished, so the live-run count returned to zero. - lookup "keiro.workflow.active" scalars `shouldBe` Just (IntNumber 0) - - -- The resume worker increments keiro.workflow.resumed per re-invocation and - -- samples keiro.workflow.awakeables.pending each pass. - it "records a resume and the pending-awakeable count when the worker re-invokes" $ \storeHandle -> do - (exporter, ref) <- inMemoryMetricExporter - (provider, _env) <- - createMeterProvider - emptyMaterializedResources - defaultSdkMeterProviderOptions{metricExporter = Just exporter} - meter <- getMeter provider Telemetry.keiroInstrumentationLibrary - metrics <- Telemetry.newKeiroMetrics meter - counter <- newIORef (0 :: Int) - let name = WorkflowName "obs-resume" - wid = WorkflowId "obs-r-1" - -- Suspend a workflow so it has a step row but no completion: the resume - -- worker will re-invoke it (and stay Suspended, which still counts as a - -- re-invocation). - suspended <- Store.runStoreIO storeHandle $ runWorkflow name wid (stepThenAwaitWorkflow counter) - suspended `shouldBe` Right Suspended - -- Register one pending awakeable (independent of the suspended workflow's - -- own await) so the pending gauge has something to count. - let aid = awakeableIdToUuid (deterministicAwakeableId (WorkflowName "ext") (WorkflowId "1") "cb") - Right () <- - Store.runStoreIO storeHandle $ Store.runTransaction $ Awk.registerAwakeableTx aid "ext" "1" - -- One resume pass with metrics threaded through the run options. - let registry = Map.singleton name (WorkflowDef (\_wid -> stepThenAwaitWorkflow counter)) - resumeOpts = - defaultWorkflowResumeOptions - & #runOptions - .~ (defaultWorkflowRunOptions & #metrics .~ Just metrics) - Right _summary <- Store.runStoreIO storeHandle $ resumeWorkflowsOnce resumeOpts registry - _ <- forceFlushMeterProvider provider Nothing - exported <- readIORef ref - let scalars = flattenScalarPoints exported - lookup "keiro.workflow.resumed" scalars `shouldBe` Just (IntNumber 1) - lookup "keiro.workflow.awakeables.pending" scalars `shouldBe` Just (IntNumber 1) - - -- The no-op idiom end to end: defaultWorkflowRunOptions carries metrics = - -- Nothing, so a run on a dedicated provider exports no points at all. - it "records nothing through a Nothing handle" $ \storeHandle -> do - (exporter, ref) <- inMemoryMetricExporter - (provider, _env) <- - createMeterProvider - emptyMaterializedResources - defaultSdkMeterProviderOptions{metricExporter = Just exporter} - counter <- newIORef (0 :: Int) - result <- - Store.runStoreIO storeHandle $ - runWorkflow (WorkflowName "obs-noop") (WorkflowId "obs-n-1") (demoWorkflow counter) - result `shouldBe` Right (Completed (1, 2)) - _ <- forceFlushMeterProvider provider Nothing - exported <- readIORef ref - flattenScalarPoints exported `shouldBe` [] - flattenHistogramPoints exported `shouldBe` [] - - describe "Keiro.Workflow.Snapshot codec" $ do - -- Pure (no-DB) round-trip of the workflow state codec. - it "round-trips a non-trivial accumulated step map and carries the sentinel shape hash" $ do - let m = - Map.fromList - [ ("first", toJSON (1 :: Int)) - , ("second", toJSON ["a", "b" :: Text]) - , ("sleep:42", Aeson.Null) - ] - (workflowStateCodec ^. #decode) ((workflowStateCodec ^. #encode) m) `shouldBe` Right m - (workflowStateCodec ^. #shapeHash) `shouldBe` "keiro.workflow.stepmap.v1" - (workflowStateCodec ^. #stateShapeHash) `shouldBe` "keiro.workflow.stepmap.v1" - (workflowStateCodec ^. #stateCodecVersion) `shouldBe` 1 - - describe "Keiro.Workflow.Types journal codec" $ do - -- Pure (no-DB) round-trip of the EP-48 rotation marker, proving the - -- additive WorkflowContinuedAsNew constructor encodes and decodes - -- self-describingly within schemaVersion 1. - it "round-trips a WorkflowContinuedAsNew rotation marker" $ do - let t = UTCTime (ModifiedJulianDay 60000) (secondsToDiffTime 3600) - marker = WorkflowContinuedAsNew 3 t - (workflowJournalCodec ^. #decode) ((workflowJournalCodec ^. #eventType) marker) ((workflowJournalCodec ^. #encode) marker) - `shouldBe` Right marker - (workflowJournalCodec ^. #schemaVersion) `shouldBe` 1 - EventType "WorkflowContinuedAsNew" `elem` (workflowJournalCodec ^. #eventTypes) `shouldBe` True - - it "validates workflow identity smart constructors" $ do - mkWorkflowName "orderFulfillment" `shouldBe` Right (WorkflowName "orderFulfillment") - mkWorkflowName "" `shouldBe` Left WorkflowNameEmpty - mkWorkflowName "order-fulfillment" `shouldBe` Left (WorkflowNameInvalidChar '-' "order-fulfillment") - mkWorkflowName "order:fulfillment" `shouldBe` Left (WorkflowNameInvalidChar ':' "order:fulfillment") - mkWorkflowName "order#1" `shouldBe` Left (WorkflowNameInvalidChar '#' "order#1") - mkWorkflowId "550e8400-e29b-41d4-a716-446655440000" - `shouldBe` Right (WorkflowId "550e8400-e29b-41d4-a716-446655440000") - mkWorkflowId "" `shouldBe` Left WorkflowIdEmpty - mkWorkflowId "customer:42" `shouldBe` Left (WorkflowIdInvalidChar ':' "customer:42") - mkWorkflowId "customer#42" `shouldBe` Left (WorkflowIdInvalidChar '#' "customer#42") - - describe "Keiro.Workflow.Sleep" $ do - -- Pure (no-DB) checks of the id/payload/step-name helpers. - it "derives a deterministic, distinct timer id" $ do - let name = WorkflowName "wf" - wid = WorkflowId "w-1" - sleepGolden = uuidLiteral "a95d5e7f-a43d-5ee2-9243-8206f0d8734a" - sleepTimerId name wid 0 "sleep:cool" `shouldBe` sleepTimerId name wid 0 "sleep:cool" - (sleepTimerId name wid 0 "sleep:cool" == sleepTimerId name wid 0 "sleep:other") - `shouldBe` False - sleepTimerId name wid 0 "sleep:cool" - `shouldBe` TimerId sleepGolden - sleepTimerId name wid 1 "sleep:cool" `shouldNotBe` sleepTimerId name wid 0 "sleep:cool" - sleepTimerId name wid 2 "sleep:cool" `shouldNotBe` sleepTimerId name wid 1 "sleep:cool" - - it "round-trips and recognises its timer payload" $ do - parseSleepPayload (sleepTimerPayload 2 "sleep:cool") - `shouldBe` Just ("sleep:cool", Just 2) - parseSleepPayload - ( object - [ "kind" Aeson..= ("keiro.workflow.sleep" :: Text) - , "step" Aeson..= ("sleep:legacy" :: Text) - ] - ) - `shouldBe` Just ("sleep:legacy", Nothing) - parseSleepPayload (object ["kind" Aeson..= ("counter-timeout" :: Text)]) - `shouldBe` Nothing - - it "recovers a legacy payload's generation from its deterministic timer id" $ do - let name = WorkflowName "wf" - wid = WorkflowId "w-legacy" - full = "sleep:cool" - for_ [0 .. 2] $ \gen -> - matchSleepTimerGeneration name wid 2 full (sleepTimerId name wid gen full) - `shouldBe` Just gen - - it "prefixes the journal step name with the reserved sleep prefix" $ - sleepStepName (StepName "cool") `shouldBe` "sleep:cool" - - around (withFreshStore fixture) $ do - it "arms a timer and suspends, then a fired timer resumes the workflow" $ \storeHandle -> do - counter <- newIORef (0 :: Int) - let name = WorkflowName "sleepdemo" - wid = WorkflowId "sd-1" - journalStream = StreamName "wf:sleepdemo-sd-1" - TimerId timerUuid = sleepTimerId name wid 0 "sleep:cool" - -- First run: 'a' runs, the sleep arms a timer, and the run suspends. - outcome1 <- - Store.runStoreIO storeHandle $ - runWorkflow name wid (sleepDemoNamed counter (StepName "cool") 0) - outcome1 `shouldBe` Right Suspended - afterFirst <- readIORef counter - afterFirst `shouldBe` 1 - -- The journal holds only 'a' (no completion, no sleep:cool yet). - Right recorded1 <- - Store.runStoreIO storeHandle $ - Store.readStreamForward journalStream (StreamVersion 0) 100 - traverse (decodeRecorded workflowJournalCodec) (Vector.toList recorded1) - `shouldSatisfy` \case - Right [StepRecorded "a" _ _] -> True - _ -> False - -- The durable wait is a single Scheduled timer row carrying the - -- workflow-sleep payload. - Right timerRow <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ - Tx.statement timerUuid sleepTimerStatusStmt - timerRow `shouldSatisfy` \case - Just (status, payload) -> - status == "scheduled" - && parseSleepPayload payload == Just ("sleep:cool", Just 0) - Nothing -> False - -- Fire the timer through the routing worker (no PM fallback needed). - fireTime <- getCurrentTime - fireResult <- - Store.runStoreIO storeHandle $ - runWorkflowTimerWorker Nothing fireTime (\_ -> pure Nothing) - case fireResult of - Right (Just timer) -> timer ^. #status `shouldBe` Firing - other -> expectationFailure ("expected a fired sleep timer, got " <> show other) - -- The row is now Fired and the journal gained sleep:cool. - Right afterFire <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ - Tx.statement timerUuid sleepTimerStatusStmt - fmap fst afterFire `shouldBe` Just "fired" - Right recorded2 <- - Store.runStoreIO storeHandle $ - Store.readStreamForward journalStream (StreamVersion 0) 100 - traverse (decodeRecorded workflowJournalCodec) (Vector.toList recorded2) - `shouldSatisfy` \case - Right [StepRecorded "a" _ _, StepRecorded "sleep:cool" _ _] -> True - _ -> False - -- Second run completes: 'a' and the sleep short-circuit, only 'b' runs. - outcome2 <- - Store.runStoreIO storeHandle $ - runWorkflow name wid (sleepDemoNamed counter (StepName "cool") 0) - outcome2 `shouldBe` Right (Completed (1, 2)) - afterSecond <- readIORef counter - afterSecond `shouldBe` 2 - Right recorded3 <- - Store.runStoreIO storeHandle $ - Store.readStreamForward journalStream (StreamVersion 0) 100 - traverse (decodeRecorded workflowJournalCodec) (Vector.toList recorded3) - `shouldSatisfy` \case - Right [StepRecorded "a" _ _, StepRecorded "sleep:cool" _ _, StepRecorded "b" _ _, WorkflowCompleted _] -> True - _ -> False - - it "respects a positive delay: not due before fire_at, fires after" $ \storeHandle -> do - counter <- newIORef (0 :: Int) - let name = WorkflowName "sleepwait" - wid = WorkflowId "rt-1" - journalStream = StreamName "wf:sleepwait-rt-1" - clockBeforeFire <- getCurrentTime - outcome1 <- - Store.runStoreIO storeHandle $ - runWorkflow name wid (sleepDemoNamed counter (StepName "wait") 1) - outcome1 `shouldBe` Right Suspended - afterFirst <- readIORef counter - afterFirst `shouldBe` 1 - -- A worker whose clock is before fire_at claims nothing. - notDue <- - Store.runStoreIO storeHandle $ - runTimerWorker Nothing clockBeforeFire workflowSleepFireAction - notDue `shouldBe` Right Nothing - Right recordedMid <- - Store.runStoreIO storeHandle $ - Store.readStreamForward journalStream (StreamVersion 0) 100 - traverse (decodeRecorded workflowJournalCodec) (Vector.toList recordedMid) - `shouldSatisfy` \case - Right [StepRecorded "a" _ _] -> True - _ -> False - -- Wait out the one-second delay, then the worker fires it. - threadDelay 1_200_000 - afterDelay <- getCurrentTime - fired <- - Store.runStoreIO storeHandle $ - runTimerWorker Nothing afterDelay workflowSleepFireAction - fired `shouldSatisfy` \case - Right (Just _) -> True - _ -> False - Right recordedWoken <- - Store.runStoreIO storeHandle $ - Store.readStreamForward journalStream (StreamVersion 0) 100 - traverse (decodeRecorded workflowJournalCodec) (Vector.toList recordedWoken) - `shouldSatisfy` \case - Right [StepRecorded "a" _ _, StepRecorded "sleep:wait" _ _] -> True - _ -> False - outcome2 <- - Store.runStoreIO storeHandle $ - runWorkflow name wid (sleepDemoNamed counter (StepName "wait") 1) - outcome2 `shouldBe` Right (Completed (1, 2)) - afterSecond <- readIORef counter - afterSecond `shouldBe` 2 - - it "does not postpone fire_at when a resume pass re-arms the sleep" $ \storeHandle -> do - counter <- newIORef (0 :: Int) - let name = WorkflowName "sleeponce" - wid = WorkflowId "so-1" - TimerId timerUuid = sleepTimerId name wid 0 "sleep:cool" - registry = Map.singleton name (WorkflowDef (\_ -> sleepDemoNamed counter (StepName "cool") 300)) - Right Suspended <- - Store.runStoreIO storeHandle $ - runWorkflow name wid (sleepDemoNamed counter (StepName "cool") 300) - Right (Just firstFireAt) <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ - Tx.statement timerUuid sleepTimerFireAtStmt - Right summary <- - Store.runStoreIO storeHandle $ - resumeWorkflowsOnce defaultWorkflowResumeOptions registry - discovered summary `shouldBe` 0 - Right (Just secondFireAt) <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ - Tx.statement timerUuid sleepTimerFireAtStmt - secondFireAt `shouldBe` firstFireAt - readIORef counter >>= (`shouldBe` 1) - - it "keeps a due wake_after stable on re-arm and clears it on fire" $ \storeHandle -> do - counter <- newIORef (0 :: Int) - let name = WorkflowName "sleep-wake-stable" - wid = WorkflowId "sws-1" - registry = Map.singleton name (WorkflowDef (\_ -> sleepDemoNamed counter (StepName "wait") 0)) - Right Suspended <- - Store.runStoreIO storeHandle $ - runWorkflow name wid (sleepDemoNamed counter (StepName "wait") 0) - Right (Just firstWakeAfter) <- - Store.runStoreIO storeHandle $ - workflowWakeAfter name wid - - Right rearmed <- - Store.runStoreIO storeHandle $ - resumeWorkflowsOnce defaultWorkflowResumeOptions registry - discovered rearmed `shouldBe` 1 - Right (Just secondWakeAfter) <- - Store.runStoreIO storeHandle $ - workflowWakeAfter name wid - secondWakeAfter `shouldBe` firstWakeAfter - - fireTime <- getCurrentTime - Right (Just _) <- - Store.runStoreIO storeHandle $ - runWorkflowTimerWorker Nothing fireTime (\_ -> pure Nothing) - Right clearedWakeAfter <- - Store.runStoreIO storeHandle $ - workflowWakeAfter name wid - clearedWakeAfter `shouldBe` Nothing - - Right resumed <- - Store.runStoreIO storeHandle $ - resumeWorkflowsOnce defaultWorkflowResumeOptions registry - discovered resumed `shouldBe` 1 - completed resumed `shouldBe` 1 - readIORef counter >>= (`shouldBe` 2) - - it "skips a sleeping workflow until wake_after expires" $ \storeHandle -> do - counter <- newIORef (0 :: Int) - let name = WorkflowName "sleepwakeafter" - wid = WorkflowId "swa-1" - Right Suspended <- - Store.runStoreIO storeHandle $ - runWorkflow name wid (sleepDemoNamed counter (StepName "wait") 60) - now <- getCurrentTime - Right mWakeAfter <- Store.runStoreIO storeHandle $ workflowWakeAfter name wid - case mWakeAfter of - Nothing -> expectationFailure "expected wake_after" - Just wakeAfter -> wakeAfter `shouldSatisfy` (> now) - Right early <- Store.runStoreIO storeHandle $ findUnfinishedWorkflowIds now - early `shouldBe` [] - Right due <- Store.runStoreIO storeHandle $ findUnfinishedWorkflowIds (addUTCTime 61 now) - due `shouldBe` [("swa-1", "sleepwakeafter")] - - it "does not re-invoke a parked sleeper before wake_after" $ \storeHandle -> do - counter <- newIORef (0 :: Int) - let name = WorkflowName "sleepquiet" - wid = WorkflowId "sq-1" - registry = Map.singleton name (WorkflowDef (\_ -> sleepDemoNamed counter (StepName "wait") 60)) - pass = Store.runStoreIO storeHandle (resumeWorkflowsOnce defaultWorkflowResumeOptions registry) - Right Suspended <- - Store.runStoreIO storeHandle $ - runWorkflow name wid (sleepDemoNamed counter (StepName "wait") 60) - Right s1 <- pass - Right s2 <- pass - Right s3 <- pass - map discovered [s1, s2, s3] `shouldBe` [0, 0, 0] - readIORef counter >>= (`shouldBe` 1) - - it "treats a missing instance row during sleep arm as a no-op wake hint update" $ \storeHandle -> do - let name = WorkflowName "sleepmissingrow" - wid = WorkflowId "smr-1" - body = sleepNamed (StepName "wait") 60 >> pure () - Right Suspended <- Store.runStoreIO storeHandle $ runWorkflow name wid body - Right () <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ - Tx.statement ("smr-1", "sleepmissingrow") deleteWorkflowInstanceStmt - Store.runStoreIO storeHandle (runWorkflow name wid body) - `shouldReturn` Right Suspended - - it "fires a sleep whose instance row is missing after an arm crash" $ \storeHandle -> do - let name = WorkflowName "sleep-missing-fire" - wid = WorkflowId "smf-1" - body = sleepNamed (StepName "wait") 0 - Right Suspended <- Store.runStoreIO storeHandle $ runWorkflow name wid body - Right () <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ - Tx.statement ("smf-1", "sleep-missing-fire") deleteWorkflowInstanceStmt - fireTime <- getCurrentTime - Right (Just _) <- - Store.runStoreIO storeHandle $ - runWorkflowTimerWorker Nothing fireTime (\_ -> pure Nothing) - Right resolved <- - Store.runStoreIO storeHandle $ - stepExists name wid 0 "sleep:wait" - resolved `shouldBe` True - Right (Just recovered) <- - Store.runStoreIO storeHandle $ - Instance.lookupInstance name wid - recovered ^. #status `shouldBe` Instance.WfRunning - Store.runStoreIO storeHandle (runWorkflow name wid body) - `shouldReturn` Right (Completed ()) - - it "fires a sleep longer than the resume cadence under an active resume worker" $ \storeHandle -> do - counter <- newIORef (0 :: Int) - let name = WorkflowName "sleepactive" - wid = WorkflowId "sa-1" - registry = Map.singleton name (WorkflowDef (\_ -> sleepDemoNamed counter (StepName "wait") 1)) - Right Suspended <- - Store.runStoreIO storeHandle $ - runWorkflow name wid (sleepDemoNamed counter (StepName "wait") 1) - threadDelay 1_200_000 - Right boundaryPass <- - Store.runStoreIO storeHandle $ - resumeWorkflowsOnce defaultWorkflowResumeOptions registry - discovered boundaryPass `shouldBe` 1 - fireTime <- getCurrentTime - Right (Just _) <- - Store.runStoreIO storeHandle $ - runWorkflowTimerWorker Nothing fireTime (\_ -> pure Nothing) - Right completionPass <- - Store.runStoreIO storeHandle $ - resumeWorkflowsOnce defaultWorkflowResumeOptions registry - discovered completionPass `shouldBe` 1 - completed completionPass `shouldBe` 1 - readIORef counter >>= (`shouldBe` 2) - - it "uses generation-namespaced timer ids after continueAsNew" $ \storeHandle -> do - counter <- newIORef (0 :: Int) - let name = WorkflowName "sleeproll" - wid = WorkflowId "sr-1" - registry = Map.singleton name (WorkflowDef (\_ -> rollingSleepWorkflow counter)) - drive 0 = expectationFailure "rolling sleep did not complete" - drive n = do - Right summary <- - Store.runStoreIO storeHandle $ - resumeWorkflowsOnce defaultWorkflowResumeOptions registry - now <- getCurrentTime - _ <- - Store.runStoreIO storeHandle $ - runWorkflowTimerWorker Nothing now (\_ -> pure Nothing) - if completed summary == 1 - then pure () - else drive (n - 1) - Right Suspended <- Store.runStoreIO storeHandle $ runWorkflow name wid (rollingSleepWorkflow counter) - drive (12 :: Int) - readIORef counter >>= (`shouldBe` 3) - - describe "Keiro.Workflow sleep generation pinning" $ around (withFreshStore fixture) $ do - it "keeps a stale re-fire on the generation that armed the sleep" $ \storeHandle -> do - counter <- newIORef (0 :: Int) - let name = WorkflowName "sleep-generation-pin" - wid = WorkflowId "sgp-1" - full = "sleep:cool" - TimerId generationZeroTimerId = sleepTimerId name wid 0 full - TimerId generationOneTimerId = sleepTimerId name wid 1 full - body = do - seed <- restoreSeed (0 :: Int) - _ <- step (StepName "work") (liftIO (incrementAndRead counter)) - if seed == 0 - then sleepNamed (StepName "cool") 0 >> continueAsNew (1 :: Int) - else sleepNamed (StepName "cool") 3600 >> pure seed - - Right Suspended <- Store.runStoreIO storeHandle $ runWorkflow name wid body - claimTime <- getCurrentTime - Right (Just claimed) <- Store.runStoreIO storeHandle $ claimDueTimer claimTime - claimed ^. #timerId `shouldBe` TimerId generationZeroTimerId - Right (Just _) <- - Store.runStoreIO storeHandle $ - workflowSleepFireAction claimed - - Right ContinuedAsNew <- Store.runStoreIO storeHandle $ runWorkflow name wid body - Right Suspended <- Store.runStoreIO storeHandle $ runWorkflow name wid body - Right (Just generationOneFireAt) <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ - Tx.statement generationOneTimerId sleepTimerFireAtStmt - - requeueTime <- getCurrentTime - Right requeued <- - Store.runStoreIO storeHandle $ - requeueStuckTimers 0 (addUTCTime 1 requeueTime) - requeued `shouldBe` 1 - Right (Just staleFire) <- - Store.runStoreIO storeHandle $ - runWorkflowTimerWorker Nothing (addUTCTime 2 requeueTime) (\_ -> pure Nothing) - staleFire ^. #timerId `shouldBe` TimerId generationZeroTimerId - - Right generationOneResolved <- - Store.runStoreIO storeHandle $ - stepExists name wid 1 full - generationOneResolved `shouldBe` False - Right (Just instanceRow) <- - Store.runStoreIO storeHandle $ - Instance.lookupInstance name wid - instanceRow ^. #status `shouldBe` Instance.WfSuspended - Right generationZeroStatus <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ - Tx.statement generationZeroTimerId sleepTimerStatusStmt - fmap fst generationZeroStatus `shouldBe` Just "fired" - Right generationOneStatus <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ - Tx.statement generationOneTimerId sleepTimerStatusStmt - fmap fst generationOneStatus `shouldBe` Just "scheduled" - Right (Just generationOneFireAtAfter) <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ - Tx.statement generationOneTimerId sleepTimerFireAtStmt - generationOneFireAtAfter `shouldBe` generationOneFireAt - readIORef counter >>= (`shouldBe` 2) - - describe "Keiro.Workflow.Awakeable" $ do - -- Pure (no-DB) check of the deterministic id derivation. - it "derives a deterministic AwakeableId, stable across calls and label-sensitive" $ do - let aid1 = deterministicAwakeableId (WorkflowName "w") (WorkflowId "1") "approval" - aid2 = deterministicAwakeableId (WorkflowName "w") (WorkflowId "1") "approval" - aidOther = deterministicAwakeableId (WorkflowName "w") (WorkflowId "1") "other" - awakeableGolden = uuidLiteral "ccaeaf74-3ffe-5ea5-a118-a3441a95c279" - aid1 `shouldBe` aid2 - (aid1 == aidOther) `shouldBe` False - aid1 `shouldBe` AwakeableId awakeableGolden - - around (withFreshStore fixture) $ do - it "schema: registers, completes once (idempotent), cancels, and counts pending rows" $ \storeHandle -> do - let aidA = awakeableIdToUuid (deterministicAwakeableId (WorkflowName "sch") (WorkflowId "1") "a") - aidB = awakeableIdToUuid (deterministicAwakeableId (WorkflowName "sch") (WorkflowId "1") "b") - now <- getCurrentTime - Right () <- Store.runStoreIO storeHandle $ Store.runTransaction $ do - Awk.registerAwakeableTx aidA "sch" "1" - Awk.registerAwakeableTx aidB "sch" "1" - Right pendingCount <- Store.runStoreIO storeHandle Awk.countPendingAwakeables - pendingCount `shouldBe` 2 - Right (Just rowA) <- Store.runStoreIO storeHandle $ Awk.lookupAwakeable aidA - rowA ^. #status `shouldBe` Awk.Pending - rowA ^. #payload `shouldBe` Nothing - -- Complete A once; the status-guarded UPDATE makes a re-complete a no-op. - Right firstComplete <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ - Awk.completeAwakeableTx aidA (toJSON ("done" :: Text)) now - firstComplete `shouldBe` True - Right secondComplete <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ - Awk.completeAwakeableTx aidA (toJSON ("again" :: Text)) now - secondComplete `shouldBe` False - Right (Just rowA') <- Store.runStoreIO storeHandle $ Awk.lookupAwakeable aidA - rowA' ^. #status `shouldBe` Awk.Completed - rowA' ^. #payload `shouldBe` Just (toJSON ("done" :: Text)) - -- Cancel the still-pending B; both rows are now resolved. - Right cancelled <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ - Awk.cancelAwakeableTx aidB - cancelled `shouldBe` True - Right pendingAfter <- Store.runStoreIO storeHandle Awk.countPendingAwakeables - pendingAfter `shouldBe` 0 - - it "suspends on an unsignalled awakeable, recording a pending row and no completion" $ \storeHandle -> do - aidRef <- newIORef Nothing - let name = WorkflowName "approval" - wid = WorkflowId "wf1" - outcome1 <- Store.runStoreIO storeHandle $ runWorkflow name wid (approvalFlowWithId aidRef) - outcome1 `shouldBe` Right Suspended - aid <- readRequiredAwakeableId aidRef - Right (Just row) <- Store.runStoreIO storeHandle $ Awk.lookupAwakeable (awakeableIdToUuid aid) - row ^. #status `shouldBe` Awk.Pending - row ^. #payload `shouldBe` Nothing - Right pendingNow <- Store.runStoreIO storeHandle Awk.countPendingAwakeables - pendingNow `shouldBe` 1 - Right recorded <- - Store.runStoreIO storeHandle $ - Store.readStreamForward (StreamName "wf:approval-wf1") (StreamVersion 0) 100 - traverse (decodeRecorded workflowJournalCodec) (Vector.toList recorded) - `shouldSatisfy` \case - Right [StepRecorded stepName value _] -> - stepName == awakeableAllocStepPrefix <> "approval" && value == toJSON aid - _ -> False - - it "resumes with the signalled payload after signalAwakeable" $ \storeHandle -> do - aidRef <- newIORef Nothing - let name = WorkflowName "approval" - wid = WorkflowId "wf1" - Right Suspended <- Store.runStoreIO storeHandle $ runWorkflow name wid (approvalFlowWithId aidRef) - aid <- readRequiredAwakeableId aidRef - let awkStep = "awk:" <> awakeableIdText aid - Right signalled <- Store.runStoreIO storeHandle $ signalAwakeable aid ("ok" :: Text) - signalled `shouldBe` True - Right (Just row) <- Store.runStoreIO storeHandle $ Awk.lookupAwakeable (awakeableIdToUuid aid) - row ^. #status `shouldBe` Awk.Completed - row ^. #payload `shouldBe` Just (toJSON ("ok" :: Text)) - Right afterSignal <- - Store.runStoreIO storeHandle $ - Store.readStreamForward (StreamName "wf:approval-wf1") (StreamVersion 0) 100 - traverse (decodeRecorded workflowJournalCodec) (Vector.toList afterSignal) - `shouldSatisfy` \case - Right [StepRecorded allocStep _ _, StepRecorded s r _] -> - allocStep == awakeableAllocStepPrefix <> "approval" && s == awkStep && r == toJSON ("ok" :: Text) - _ -> False - outcome2 <- Store.runStoreIO storeHandle $ runWorkflow name wid (approvalFlowWithId aidRef) - outcome2 `shouldBe` Right (Completed "ok!") - Right afterResume <- - Store.runStoreIO storeHandle $ - Store.readStreamForward (StreamName "wf:approval-wf1") (StreamVersion 0) 100 - traverse (decodeRecorded workflowJournalCodec) (Vector.toList afterResume) - `shouldSatisfy` \case - Right [StepRecorded allocStep _ _, StepRecorded s1 _ _, StepRecorded "use" _ _, WorkflowCompleted _] -> - allocStep == awakeableAllocStepPrefix <> "approval" && s1 == awkStep - _ -> False - - it "is idempotent: a second signal returns False and does not change the value" $ \storeHandle -> do - aidRef <- newIORef Nothing - let name = WorkflowName "idem" - wid = WorkflowId "wf-i" - Right Suspended <- Store.runStoreIO storeHandle $ runWorkflow name wid (approvalFlowWithId aidRef) - aid <- readRequiredAwakeableId aidRef - let awkStep = "awk:" <> awakeableIdText aid - Right True <- Store.runStoreIO storeHandle $ signalAwakeable aid ("ok" :: Text) - Right again <- Store.runStoreIO storeHandle $ signalAwakeable aid ("later" :: Text) - again `shouldBe` False - Right (Just row) <- Store.runStoreIO storeHandle $ Awk.lookupAwakeable (awakeableIdToUuid aid) - row ^. #payload `shouldBe` Just (toJSON ("ok" :: Text)) - Right recorded <- - Store.runStoreIO storeHandle $ - Store.readStreamForward (StreamName "wf:idem-wf-i") (StreamVersion 0) 100 - Right decoded <- pure (traverse (decodeRecorded workflowJournalCodec) (Vector.toList recorded)) - [r | StepRecorded s r _ <- decoded, s == awkStep] `shouldBe` [toJSON ("ok" :: Text)] - - it "throws WorkflowAwakeableCancelled after cancelAwakeable" $ \storeHandle -> do - aidRef <- newIORef Nothing - let name = WorkflowName "cancelwf" - wid = WorkflowId "wf2" - Right Suspended <- Store.runStoreIO storeHandle $ runWorkflow name wid (approvalFlowWithId aidRef) - aid <- readRequiredAwakeableId aidRef - Right cancelled <- Store.runStoreIO storeHandle $ cancelAwakeable aid - cancelled `shouldBe` True - Right (Just row) <- Store.runStoreIO storeHandle $ Awk.lookupAwakeable (awakeableIdToUuid aid) - row ^. #status `shouldBe` Awk.Cancelled - Store.runStoreIO storeHandle (runWorkflow name wid (approvalFlowWithId aidRef)) - `shouldThrow` (== WorkflowAwakeableCancelled aid) - Right recorded <- - Store.runStoreIO storeHandle $ - Store.readStreamForward (StreamName "wf:cancelwf-wf2") (StreamVersion 0) 100 - Right decoded <- pure (traverse (decodeRecorded workflowJournalCodec) (Vector.toList recorded)) - any (\case WorkflowCompleted{} -> True; _ -> False) decoded `shouldBe` False - - it "re-appends a missing journal entry when re-signalled (crash-safe)" $ \storeHandle -> do - aidRef <- newIORef Nothing - let name = WorkflowName "crash" - wid = WorkflowId "wf3" - Right Suspended <- Store.runStoreIO storeHandle $ runWorkflow name wid (approvalFlowWithId aidRef) - aid <- readRequiredAwakeableId aidRef - let awkStep = "awk:" <> awakeableIdText aid - -- Simulate "row completed but the journal append did not happen" by - -- completing the row directly, bypassing signalAwakeable's journal write. - now <- getCurrentTime - Right completedRow <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ - Awk.completeAwakeableTx (awakeableIdToUuid aid) (toJSON ("ok" :: Text)) now - completedRow `shouldBe` True - Right beforeRepair <- - Store.runStoreIO storeHandle $ - Store.readStreamForward (StreamName "wf:crash-wf3") (StreamVersion 0) 100 - Right beforeDecoded <- pure (traverse (decodeRecorded workflowJournalCodec) (Vector.toList beforeRepair)) - [() | StepRecorded s _ _ <- beforeDecoded, s == awkStep] `shouldBe` [] - -- A re-signal with the same payload returns False (already completed) but - -- repairs the missing journal entry from the stored payload. - Right repaired <- Store.runStoreIO storeHandle $ signalAwakeable aid ("ok" :: Text) - repaired `shouldBe` False - Right afterRepair <- - Store.runStoreIO storeHandle $ - Store.readStreamForward (StreamName "wf:crash-wf3") (StreamVersion 0) 100 - Right afterDecoded <- pure (traverse (decodeRecorded workflowJournalCodec) (Vector.toList afterRepair)) - [r | StepRecorded s r _ <- afterDecoded, s == awkStep] `shouldBe` [toJSON ("ok" :: Text)] - - it "repairs a completed awakeable row from the await arm without a second signal" $ \storeHandle -> do - aidRef <- newIORef Nothing - let name = WorkflowName "crash-arm" - wid = WorkflowId "wf4" - Right Suspended <- Store.runStoreIO storeHandle $ runWorkflow name wid (approvalFlowWithId aidRef) - aid <- readRequiredAwakeableId aidRef - let awkStep = "awk:" <> awakeableIdText aid - now <- getCurrentTime - Right True <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ - Awk.completeAwakeableTx (awakeableIdToUuid aid) (toJSON ("ok" :: Text)) now - repairedRun <- Store.runStoreIO storeHandle $ runWorkflow name wid (approvalFlowWithId aidRef) - repairedRun `shouldBe` Right Suspended - Right repairedJournal <- - Store.runStoreIO storeHandle $ - Store.readStreamForward (StreamName "wf:crash-arm-wf4") (StreamVersion 0) 100 - Right repairedDecoded <- pure (traverse (decodeRecorded workflowJournalCodec) (Vector.toList repairedJournal)) - [r | StepRecorded s r _ <- repairedDecoded, s == awkStep] `shouldBe` [toJSON ("ok" :: Text)] - completed <- Store.runStoreIO storeHandle $ runWorkflow name wid (approvalFlowWithId aidRef) - completed `shouldBe` Right (Completed "ok!") - - it "refuses a forged coordinate-derived id for a fresh awakeable" $ \storeHandle -> do - aidRef <- newIORef Nothing - let name = WorkflowName "fresh-awake" - wid = WorkflowId "fa-1" - forged = deterministicAwakeableId name wid "approval" - Right Suspended <- Store.runStoreIO storeHandle $ runWorkflow name wid (approvalFlowWithId aidRef) - real <- readRequiredAwakeableId aidRef - real `shouldNotBe` forged - Right forgedSignal <- Store.runStoreIO storeHandle $ signalAwakeable forged ("bad" :: Text) - forgedSignal `shouldBe` False - Right stillSuspended <- Store.runStoreIO storeHandle $ runWorkflow name wid (approvalFlowWithId aidRef) - stillSuspended `shouldBe` Suspended - Right realSignal <- Store.runStoreIO storeHandle $ signalAwakeable real ("ok" :: Text) - realSignal `shouldBe` True - completed <- Store.runStoreIO storeHandle $ runWorkflow name wid (approvalFlowWithId aidRef) - completed `shouldBe` Right (Completed "ok!") - - it "adopts a generation-0 legacy deterministic row" $ \storeHandle -> do - aidRef <- newIORef Nothing - let name = WorkflowName "legacy-awake" - wid = WorkflowId "la-1" - legacy = deterministicAwakeableId name wid "approval" - Right () <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ - Awk.registerAwakeableTx (awakeableIdToUuid legacy) (unWorkflowName name) (unWorkflowId wid) - Right Suspended <- Store.runStoreIO storeHandle $ runWorkflow name wid (approvalFlowWithId aidRef) - adopted <- readRequiredAwakeableId aidRef - adopted `shouldBe` legacy - Right True <- Store.runStoreIO storeHandle $ signalAwakeable legacy ("ok" :: Text) - completed <- Store.runStoreIO storeHandle $ runWorkflow name wid (approvalFlowWithId aidRef) - completed `shouldBe` Right (Completed "ok!") - - it "allocates a fresh awakeable for the same label after continueAsNew" $ \storeHandle -> do - idsRef <- newIORef [] - let name = WorkflowName "awake-roll" - wid = WorkflowId "ar-1" - body = rollingAwakeableWorkflow idsRef - Right Suspended <- Store.runStoreIO storeHandle $ runWorkflow name wid body - ids1 <- readIORef idsRef - [firstAid] <- pure ids1 - Right True <- Store.runStoreIO storeHandle $ signalAwakeable firstAid ("first" :: Text) - Right ContinuedAsNew <- Store.runStoreIO storeHandle $ runWorkflow name wid body - Right Suspended <- Store.runStoreIO storeHandle $ runWorkflow name wid body - ids2 <- readIORef idsRef - case ids2 of - [firstAgain, secondAid] -> do - firstAgain `shouldBe` firstAid - secondAid `shouldNotBe` firstAid - Right staleSignal <- Store.runStoreIO storeHandle $ signalAwakeable firstAid ("stale" :: Text) - staleSignal `shouldBe` False - Right stillSuspended <- Store.runStoreIO storeHandle $ runWorkflow name wid body - stillSuspended `shouldBe` Suspended - Right True <- Store.runStoreIO storeHandle $ signalAwakeable secondAid ("second" :: Text) - completed <- Store.runStoreIO storeHandle $ runWorkflow name wid body - completed `shouldBe` Right (Completed "second") - other -> expectationFailure ("expected two awakeable ids, got " <> show other) - - describe "Keiro.Workflow awakeable registration" $ around (withFreshStore fixture) $ do - it "registers the row before a journaled hand-off can expose the id" $ \storeHandle -> do - aidRef <- newIORef Nothing - let name = WorkflowName "awakeable-signal-gap" - wid = WorkflowId "asg-1" - Right Suspended <- - Store.runStoreIO storeHandle $ - runWorkflow name wid (publishAwakeableBeforeAwait aidRef) - aid <- readRequiredAwakeableId aidRef - Right (Just pendingRow) <- - Store.runStoreIO storeHandle $ - Awk.lookupAwakeable (awakeableIdToUuid aid) - pendingRow ^. #status `shouldBe` Awk.Pending - - Right signalled <- - Store.runStoreIO storeHandle $ - signalAwakeable aid ("ok" :: Text) - signalled `shouldBe` True - Right (Just completedRow) <- - Store.runStoreIO storeHandle $ - Awk.lookupAwakeable (awakeableIdToUuid aid) - completedRow ^. #status `shouldBe` Awk.Completed - - let unknown = - AwakeableId - (uuidLiteral "00000000-0000-0000-0000-0000000002f2") - Right unknownSignal <- - Store.runStoreIO storeHandle $ - signalAwakeable unknown ("forged" :: Text) - unknownSignal `shouldBe` False - - completed <- - Store.runStoreIO storeHandle $ - runWorkflow name wid (awaitPublishedAwakeable aidRef) - completed `shouldBe` Right (Completed "ok") - - describe "Keiro.Workflow awakeable signal race" $ around (withFreshStore fixture) $ do - it "does not append a value when cancellation wins after the signal pre-read" $ \storeHandle -> do - aidRef <- newIORef Nothing - let name = WorkflowName "awakeable-cancel-race" - wid = WorkflowId "acr-1" - Right Suspended <- - Store.runStoreIO storeHandle $ - runWorkflow name wid (approvalFlowWithId aidRef) - aid <- readRequiredAwakeableId aidRef - Right (Just stalePendingRow) <- - Store.runStoreIO storeHandle $ - Awk.lookupAwakeable (awakeableIdToUuid aid) - Right cancelled <- Store.runStoreIO storeHandle $ cancelAwakeable aid - cancelled `shouldBe` True - Right signalled <- - Store.runStoreIO storeHandle $ - signalAwakeableFrom stalePendingRow ("late" :: Text) - signalled `shouldBe` False - Right recorded <- - Store.runStoreIO storeHandle $ - stepExists - name - wid - 0 - (awakeableStepPrefix <> awakeableIdText aid) - recorded `shouldBe` False - Store.runStoreIO storeHandle (runWorkflow name wid (approvalFlowWithId aidRef)) - `shouldThrow` (== WorkflowAwakeableCancelled aid) - - describe "Keiro.Workflow.Child" $ do - -- M2: the reserved spawn/result step-name derivations are stable. - it "derives the child spawn and result step names" $ do - childSpawnStepName (WorkflowId "c1") `shouldBe` "child:c1" - childResultStepName (WorkflowId "c1") `shouldBe` "child:c1:result" - - -- M3(a): the new terminal journal constructors round-trip through the codec. - it "round-trips WorkflowCancelled and WorkflowFailed through the journal codec" $ do - let t = UTCTime (ModifiedJulianDay 0) 0 - rt ev = (workflowJournalCodec ^. #decode) ((workflowJournalCodec ^. #eventType) ev) ((workflowJournalCodec ^. #encode) ev) - rt (WorkflowCancelled t) `shouldBe` Right (WorkflowCancelled t) - rt (WorkflowFailed "boom" t) `shouldBe` Right (WorkflowFailed "boom" t) - - around (withFreshStore fixture) $ do - -- M1: the keiro_workflow_children table and its schema helpers. - it "schema: registers, completes, cancels, and counts child links" $ \storeHandle -> do - Right () <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ - Child.registerChildTx "c-1" "ship" "p-1" "parent" "child:c-1:result" - Right (Just row) <- Store.runStoreIO storeHandle $ Child.lookupChild "c-1" "ship" - row ^. #status `shouldBe` Child.Running - row ^. #parentId `shouldBe` "p-1" - row ^. #parentName `shouldBe` "parent" - row ^. #awaitStep `shouldBe` "child:c-1:result" - now <- getCurrentTime - Right firstComplete <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ - Child.markChildResultTx "c-1" "ship" (toJSON ("packed+labelled" :: Text)) now - firstComplete `shouldBe` True - Right secondComplete <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ - Child.markChildResultTx "c-1" "ship" (toJSON ("again" :: Text)) now - secondComplete `shouldBe` False - Right () <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ - Child.registerChildTx "c-2" "ship" "p-1" "parent" "child:c-2:result" - Right cancelled <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ - Child.markChildCancelledTx "c-2" "ship" - cancelled `shouldBe` True - Right kids <- Store.runStoreIO storeHandle $ Child.lookupChildrenOfParent "p-1" "parent" - map (^. #childId) kids `shouldBe` ["c-1", "c-2"] - Right active <- Store.runStoreIO storeHandle Child.countActiveChildren - active `shouldBe` (0 :: Int) - Right st <- Store.runStoreIO storeHandle $ Child.childStatus "c-1" "ship" - st `shouldBe` Just Child.ChildCompleted - - -- M4: spawn -> drive the child (with the completion hook) -> resume parent. - it "spawns a child, drives it, propagates its result, and resumes the parent to Completed" $ \storeHandle -> do - let childWid = WorkflowId "ship-1" - suspended <- - Store.runStoreIO storeHandle $ - runWorkflow (WorkflowName "parent") (WorkflowId "p1") (parentWorkflow childWid) - suspended `shouldBe` Right Suspended - Right parentJournal1 <- - Store.runStoreIO storeHandle $ - Store.readStreamForward (StreamName "wf:parent-p1") (StreamVersion 0) 10 - Right decoded1 <- pure (traverse (decodeRecorded workflowJournalCodec) (Vector.toList parentJournal1)) - decoded1 `shouldSatisfy` \case - [StepRecorded "child:ship-1" _ _] -> True - _ -> False - Right (Just childRow) <- Store.runStoreIO storeHandle $ Child.lookupChild "ship-1" "ship" - childRow ^. #status `shouldBe` Child.Running - childRow ^. #parentId `shouldBe` "p1" - childRow ^. #parentName `shouldBe` "parent" - childRow ^. #awaitStep `shouldBe` "child:ship-1:result" - -- 2) drive the child through runChildWorkflow (propagates on completion). - childOutcome <- - Store.runStoreIO storeHandle $ - runChildWorkflow defaultWorkflowRunOptions (WorkflowName "ship") childWid shipWorkflow - childOutcome `shouldBe` Right (Completed "packed+labelled") - Right childJournal <- - Store.runStoreIO storeHandle $ - Store.readStreamForward (StreamName "wf:ship-ship-1") (StreamVersion 0) 10 - traverse (decodeRecorded workflowJournalCodec) (Vector.toList childJournal) - `shouldSatisfy` \case - Right [StepRecorded "pack" _ _, StepRecorded "label" _ _, WorkflowCompleted _] -> True - _ -> False - Right parentJournal2 <- - Store.runStoreIO storeHandle $ - Store.readStreamForward (StreamName "wf:parent-p1") (StreamVersion 0) 10 - Right decoded2 <- pure (traverse (decodeRecorded workflowJournalCodec) (Vector.toList parentJournal2)) - [r | StepRecorded "child:ship-1:result" r _ <- decoded2] - `shouldBe` [object ["ok" Aeson..= ("packed+labelled" :: Text)]] - Right (Just childRow2) <- Store.runStoreIO storeHandle $ Child.lookupChild "ship-1" "ship" - childRow2 ^. #status `shouldBe` Child.ChildCompleted - -- 3) resume the parent: it replays past awaitChild and completes. - resumed <- - Store.runStoreIO storeHandle $ - runWorkflow (WorkflowName "parent") (WorkflowId "p1") (parentWorkflow childWid) - resumed `shouldBe` Right (Completed "done:packed+labelled") - Right parentJournal3 <- - Store.runStoreIO storeHandle $ - Store.readStreamForward (StreamName "wf:parent-p1") (StreamVersion 0) 10 - Right decoded3 <- pure (traverse (decodeRecorded workflowJournalCodec) (Vector.toList parentJournal3)) - any (\case StepRecorded "notify" _ _ -> True; _ -> False) decoded3 `shouldBe` True - any (\case WorkflowCompleted{} -> True; _ -> False) decoded3 `shouldBe` True - - it "repairs a completed child row from awaitChild without another completion hook" $ \storeHandle -> do - let childWid = WorkflowId "ship-crash" - Right Suspended <- - Store.runStoreIO storeHandle $ - runWorkflow (WorkflowName "parent") (WorkflowId "p-crash") (parentWorkflow childWid) - now <- getCurrentTime - Right transitioned <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ - Child.markChildResultTx "ship-crash" "ship" (toJSON ("packed+labelled" :: Text)) now - transitioned `shouldBe` True - Right beforeRepair <- - Store.runStoreIO storeHandle $ - Store.readStreamForward (StreamName "wf:parent-p-crash") (StreamVersion 0) 10 - Right beforeDecoded <- pure (traverse (decodeRecorded workflowJournalCodec) (Vector.toList beforeRepair)) - [r | StepRecorded "child:ship-crash:result" r _ <- beforeDecoded] `shouldBe` [] - repaired <- - Store.runStoreIO storeHandle $ - runWorkflow (WorkflowName "parent") (WorkflowId "p-crash") (parentWorkflow childWid) - repaired `shouldBe` Right Suspended - Right afterRepair <- - Store.runStoreIO storeHandle $ - Store.readStreamForward (StreamName "wf:parent-p-crash") (StreamVersion 0) 10 - Right afterDecoded <- pure (traverse (decodeRecorded workflowJournalCodec) (Vector.toList afterRepair)) - [r | StepRecorded "child:ship-crash:result" r _ <- afterDecoded] - `shouldBe` [object ["ok" Aeson..= ("packed+labelled" :: Text)]] - completed <- - Store.runStoreIO storeHandle $ - runWorkflow (WorkflowName "parent") (WorkflowId "p-crash") (parentWorkflow childWid) - completed `shouldBe` Right (Completed "done:packed+labelled") - - -- M5: re-invoking the parent does not re-spawn the child (crash survival). - it "does not re-spawn the child when the parent is re-invoked" $ \storeHandle -> do - let childWid = WorkflowId "ship-2" - s1 <- - Store.runStoreIO storeHandle $ - runWorkflow (WorkflowName "parent") (WorkflowId "p2") (parentWorkflow childWid) - s1 `shouldBe` Right Suspended - Right (Just beforeRow) <- Store.runStoreIO storeHandle $ Child.lookupChild "ship-2" "ship" - let createdAt0 = beforeRow ^. #createdAt - s2 <- - Store.runStoreIO storeHandle $ - runWorkflow (WorkflowName "parent") (WorkflowId "p2") (parentWorkflow childWid) - s2 `shouldBe` Right Suspended - Right parentJournal <- - Store.runStoreIO storeHandle $ - Store.readStreamForward (StreamName "wf:parent-p2") (StreamVersion 0) 10 - Right decoded <- pure (traverse (decodeRecorded workflowJournalCodec) (Vector.toList parentJournal)) - length [() | StepRecorded "child:ship-2" _ _ <- decoded] `shouldBe` 1 - Right kids <- Store.runStoreIO storeHandle $ Child.lookupChildrenOfParent "p2" "parent" - length kids `shouldBe` 1 - map (^. #createdAt) kids `shouldBe` [createdAt0] - - -- M5: cancelling a child stops it and makes the parent's awaitChild throw. - it "cancels a child: the child stops and the parent's awaitChild throws" $ \storeHandle -> do - let childWid = WorkflowId "cancel-child" - h = ChildHandle (WorkflowName "ship") childWid - s1 <- - Store.runStoreIO storeHandle $ - runWorkflow (WorkflowName "parent") (WorkflowId "p3") (parentWorkflow childWid) - s1 `shouldBe` Right Suspended - Right cancelled <- Store.runStoreIO storeHandle $ cancelChild h - cancelled `shouldBe` True - Right childJournal <- - Store.runStoreIO storeHandle $ - Store.readStreamForward (StreamName "wf:ship-cancel-child") (StreamVersion 0) 10 - Right childDecoded <- pure (traverse (decodeRecorded workflowJournalCodec) (Vector.toList childJournal)) - any (\case WorkflowCancelled{} -> True; _ -> False) childDecoded `shouldBe` True - Right st <- Store.runStoreIO storeHandle $ Child.childStatus "cancel-child" "ship" - st `shouldBe` Just Child.ChildCancelled - Right parentJournal <- - Store.runStoreIO storeHandle $ - Store.readStreamForward (StreamName "wf:parent-p3") (StreamVersion 0) 10 - Right parentDecoded <- pure (traverse (decodeRecorded workflowJournalCodec) (Vector.toList parentJournal)) - [r | StepRecorded "child:cancel-child:result" r _ <- parentDecoded] - `shouldBe` [object ["cancelled" Aeson..= True]] - -- driving the child returns Cancelled and runs none of its steps. - childOutcome <- - Store.runStoreIO storeHandle $ - runWorkflow (WorkflowName "ship") childWid shipWorkflow - childOutcome `shouldBe` Right Keiro.Workflow.Cancelled - Right childJournal2 <- - Store.runStoreIO storeHandle $ - Store.readStreamForward (StreamName "wf:ship-cancel-child") (StreamVersion 0) 10 - Right childDecoded2 <- pure (traverse (decodeRecorded workflowJournalCodec) (Vector.toList childJournal2)) - any (\case StepRecorded "pack" _ _ -> True; _ -> False) childDecoded2 `shouldBe` False - -- re-invoking the parent throws WorkflowChildCancelled. - Store.runStoreIO - storeHandle - (runWorkflow (WorkflowName "parent") (WorkflowId "p3") (parentWorkflow childWid)) - `shouldThrow` (== WorkflowChildCancelled (WorkflowName "ship") childWid) - - it "repairs a cancelled child row when cancelChild is retried after the row flip" $ \storeHandle -> do - let childWid = WorkflowId "cancel-child-crash" - h = ChildHandle (WorkflowName "ship") childWid - Right Suspended <- - Store.runStoreIO storeHandle $ - runWorkflow (WorkflowName "parent") (WorkflowId "p-cancel-crash") (parentWorkflow childWid) - Right transitioned <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ - Child.markChildCancelledTx "cancel-child-crash" "ship" - transitioned `shouldBe` True - Right retried <- Store.runStoreIO storeHandle $ cancelChild h - retried `shouldBe` False - Right childJournal <- - Store.runStoreIO storeHandle $ - Store.readStreamForward (StreamName "wf:ship-cancel-child-crash") (StreamVersion 0) 10 - Right childDecoded <- pure (traverse (decodeRecorded workflowJournalCodec) (Vector.toList childJournal)) - any (\case WorkflowCancelled{} -> True; _ -> False) childDecoded `shouldBe` True - Right parentJournal <- - Store.runStoreIO storeHandle $ - Store.readStreamForward (StreamName "wf:parent-p-cancel-crash") (StreamVersion 0) 10 - Right parentDecoded <- pure (traverse (decodeRecorded workflowJournalCodec) (Vector.toList parentJournal)) - [r | StepRecorded "child:cancel-child-crash:result" r _ <- parentDecoded] - `shouldBe` [object ["cancelled" Aeson..= True]] - - it "heals a cancelled-but-unmarked child from runChildWorkflow" $ \storeHandle -> do - let childWid = WorkflowId "cancel-child-drive" - Right Suspended <- - Store.runStoreIO storeHandle $ - runWorkflow (WorkflowName "parent") (WorkflowId "p-cancel-drive") (parentWorkflow childWid) - Right True <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ - Child.markChildCancelledTx "cancel-child-drive" "ship" - childOutcome <- - Store.runStoreIO storeHandle $ - runChildWorkflow defaultWorkflowRunOptions (WorkflowName "ship") childWid shipWorkflow - childOutcome `shouldBe` Right Keiro.Workflow.Cancelled - Right childJournal <- - Store.runStoreIO storeHandle $ - Store.readStreamForward (StreamName "wf:ship-cancel-child-drive") (StreamVersion 0) 10 - Right childDecoded <- pure (traverse (decodeRecorded workflowJournalCodec) (Vector.toList childJournal)) - any (\case WorkflowCancelled{} -> True; _ -> False) childDecoded `shouldBe` True - Right parentJournal <- - Store.runStoreIO storeHandle $ - Store.readStreamForward (StreamName "wf:parent-p-cancel-drive") (StreamVersion 0) 10 - Right parentDecoded <- pure (traverse (decodeRecorded workflowJournalCodec) (Vector.toList parentJournal)) - [r | StepRecorded "child:cancel-child-drive:result" r _ <- parentDecoded] - `shouldBe` [object ["cancelled" Aeson..= True]] - - it "delivers an honest child result equal to the old cancellation sentinel" $ \storeHandle -> do - let childWid = WorkflowId "json-cancelled-object" - Right Suspended <- - Store.runStoreIO storeHandle $ - runWorkflow (WorkflowName "json-parent") (WorkflowId "jp1") (jsonObjectParentWorkflow childWid) - childOutcome <- - Store.runStoreIO storeHandle $ - runChildWorkflow defaultWorkflowRunOptions (WorkflowName "json-child") childWid jsonObjectChildWorkflow - childOutcome `shouldBe` Right (Completed (object ["cancelled" Aeson..= True])) - completed <- - Store.runStoreIO storeHandle $ - runWorkflow (WorkflowName "json-parent") (WorkflowId "jp1") (jsonObjectParentWorkflow childWid) - completed `shouldBe` Right (Completed (object ["cancelled" Aeson..= True])) - Right parentJournal <- - Store.runStoreIO storeHandle $ - Store.readStreamForward (StreamName "wf:json-parent-jp1") (StreamVersion 0) 10 - Right parentDecoded <- pure (traverse (decodeRecorded workflowJournalCodec) (Vector.toList parentJournal)) - [r | StepRecorded "child:json-cancelled-object:result" r _ <- parentDecoded] - `shouldBe` [object ["ok" Aeson..= object ["cancelled" Aeson..= True]]] - - it "throws WorkflowStepDecodeError when an enveloped child result has the wrong type" $ \storeHandle -> do - let childWid = WorkflowId "decode-child" - Right Suspended <- - Store.runStoreIO storeHandle $ - runWorkflow (WorkflowName "parent") (WorkflowId "p-decode") (parentWorkflow childWid) - Store.runStoreIO - storeHandle - (childCompletionHook (WorkflowName "ship") childWid (toJSON (42 :: Int))) - `shouldReturn` Right () - Store.runStoreIO - storeHandle - (runWorkflow (WorkflowName "parent") (WorkflowId "p-decode") (parentWorkflow childWid)) - `shouldThrow` \case - WorkflowStepDecodeError key _ -> key == "child:decode-child:result" - _ -> False - - it "wakes a parent with WorkflowChildFailed when a child reaches the failure ceiling" $ \storeHandle -> do - let childWid = WorkflowId "failed-child" - registry = - Map.fromList - [ (WorkflowName "parent", WorkflowDef (\_ -> parentWorkflow childWid)) - , (WorkflowName "ship", WorkflowDef (\_ -> liftIO (throwIO SimulatedCrash) *> pure ("" :: Text))) - ] - opts = defaultWorkflowResumeOptions & #maxAttempts .~ 1 - Right Suspended <- - Store.runStoreIO storeHandle $ - runWorkflow (WorkflowName "parent") (WorkflowId "p-failed-child") (parentWorkflow childWid) - Right summary <- Store.runStoreIO storeHandle $ resumeWorkflowsOnce opts registry - failed summary `shouldBe` 1 - Right (Just childRow) <- Store.runStoreIO storeHandle $ Child.lookupChild "failed-child" "ship" - childRow ^. #status `shouldBe` Child.ChildFailed - Store.runStoreIO - storeHandle - (runWorkflow (WorkflowName "parent") (WorkflowId "p-failed-child") (parentWorkflow childWid)) - `shouldThrow` \case - WorkflowChildFailed (WorkflowName "ship") (WorkflowId "failed-child") reason -> - "SimulatedCrash" `Text.isInfixOf` reason - _ -> False - - it "stops at the next step boundary when a workflow is cancelled mid-run" $ \storeHandle -> do - counter <- newIORef 0 - let name = WorkflowName "self-cancel" - wid = WorkflowId "sc1" - outcome <- - Store.runStoreIO storeHandle $ - runWorkflow name wid (selfCancellingWorkflow name wid counter) - outcome `shouldBe` Right Keiro.Workflow.Cancelled - readIORef counter `shouldReturn` 2 - Right recorded <- - Store.runStoreIO storeHandle $ - Store.readStreamForward (StreamName "wf:self-cancel-sc1") (StreamVersion 0) 10 - Right decoded <- pure (traverse (decodeRecorded workflowJournalCodec) (Vector.toList recorded)) - any (\case StepRecorded "three" _ _ -> True; _ -> False) decoded `shouldBe` False - - -- EP-42 worker-driven variant: the resume worker drives both parent and - -- child from a registry, selecting childCompletionHook for the child and - -- union-discovering the zero-step child. - it "drives a parent and its child to completion through the resume worker" $ \storeHandle -> do - let childWid = WorkflowId "ship-3" - registry = - Map.fromList - [ (WorkflowName "parent", WorkflowDef (\_ -> parentWorkflow childWid)) - , (WorkflowName "ship", WorkflowDef (\_ -> shipWorkflow)) - ] - Right Suspended <- - Store.runStoreIO storeHandle $ - runWorkflow (WorkflowName "parent") (WorkflowId "p4") (parentWorkflow childWid) - let drive = Store.runStoreIO storeHandle (resumeWorkflowsOnce defaultWorkflowResumeOptions registry) - Right _ <- drive - Right _ <- drive - Right _ <- drive - Right parentJournal <- - Store.runStoreIO storeHandle $ - Store.readStreamForward (StreamName "wf:parent-p4") (StreamVersion 0) 10 - Right parentDecoded <- pure (traverse (decodeRecorded workflowJournalCodec) (Vector.toList parentJournal)) - any (\case WorkflowCompleted{} -> True; _ -> False) parentDecoded `shouldBe` True - Right (Just childRow) <- Store.runStoreIO storeHandle $ Child.lookupChild "ship-3" "ship" - childRow ^. #status `shouldBe` Child.ChildCompleted - - it "attaches to a completed child after continueAsNew" $ \storeHandle -> do - let childWid = WorkflowId "ship-rotated" - parentName = WorkflowName "parent-rotating" - parentId = WorkflowId "p-rotating" - body = rotatingParentWorkflow childWid - Right Suspended <- Store.runStoreIO storeHandle $ runWorkflow parentName parentId body - childOutcome <- - Store.runStoreIO storeHandle $ - runChildWorkflow defaultWorkflowRunOptions (WorkflowName "ship") childWid shipWorkflow - childOutcome `shouldBe` Right (Completed "packed+labelled") - Right ContinuedAsNew <- Store.runStoreIO storeHandle $ runWorkflow parentName parentId body - repair <- Store.runStoreIO storeHandle $ runWorkflow parentName parentId body - repair `shouldBe` Right Suspended - completed <- Store.runStoreIO storeHandle $ runWorkflow parentName parentId body - completed `shouldBe` Right (Completed "packed+labelled") - - describe "Keiro.Workflow.Child durable failed delivery" $ around (withFreshStore fixture) $ do - it "delivers a persisted child failure after the parent rotates past the failure journal" $ \storeHandle -> do - let childWid = WorkflowId "failed-before-rotation" - parentName = WorkflowName "parent-failure-rotation" - parentId = WorkflowId "p-failure-rotation" - registry = - Map.fromList - [ (parentName, WorkflowDef (\_ -> failedChildBeforeRotation childWid)) - , (WorkflowName "ship", WorkflowDef (\_ -> liftIO (throwIO SimulatedCrash) *> pure ("" :: Text))) - ] - opts = defaultWorkflowResumeOptions & #maxAttempts .~ 1 - Right Suspended <- - Store.runStoreIO storeHandle $ - runWorkflow parentName parentId (failedChildBeforeRotation childWid) - Right summary <- Store.runStoreIO storeHandle $ resumeWorkflowsOnce opts registry - failed summary `shouldBe` 1 - Right (Just childRow) <- - Store.runStoreIO storeHandle $ - Child.lookupChild "failed-before-rotation" "ship" - childRow ^. #status `shouldBe` Child.ChildFailed - childRow ^. #failureReason - `shouldSatisfy` maybe False ("SimulatedCrash" `Text.isInfixOf`) - Right failedOnGenerationZero <- - Store.runStoreIO storeHandle $ - stepExists - parentName - parentId - 0 - (childResultStepName childWid) - failedOnGenerationZero `shouldBe` True - - Right ContinuedAsNew <- - Store.runStoreIO storeHandle $ - runWorkflow parentName parentId (rotatePastFailedChild childWid) - Right generation <- Store.runStoreIO storeHandle $ currentGeneration parentName parentId - generation `shouldBe` 1 - Right failedOnGenerationOne <- - Store.runStoreIO storeHandle $ - stepExists - parentName - parentId - 1 - (childResultStepName childWid) - failedOnGenerationOne `shouldBe` False - - delivered <- - Store.runStoreIO storeHandle $ - runWorkflow parentName parentId (catchFailedChildAfterRotation childWid) - delivered `shouldSatisfy` \case - Right (Completed reason) -> "SimulatedCrash" `Text.isInfixOf` reason - _ -> False - - describe "Keiro.Workflow.Gc" $ around (withFreshStore fixture) $ do - it "deletes terminal workflow data after retention" $ \storeHandle -> do - let name = WorkflowName "gc-basic" - wid = WorkflowId "gb-1" - gcStreamName = workflowGenerationStreamName name wid 0 - aid = fromMaybe (error "invalid gc awakeable uuid") (fromString "00000000-0000-0000-0000-0000000000a1") - timerId = fromMaybe (error "invalid gc timer uuid") (fromString "00000000-0000-0000-0000-0000000000a2") - counter <- newIORef (0 :: Int) - Right (Completed _) <- - Store.runStoreIO storeHandle $ - runWorkflowWith - (defaultWorkflowRunOptions & #snapshotPolicy .~ OnTerminal) - name - wid - (demoWorkflow counter) - now <- getCurrentTime - Right () <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ do - Awk.registerAwakeableTx aid "gc-basic" "gb-1" - Tx.statement (timerId, "gc-basic", "gb-1", now, object ["kind" Aeson..= ("keiro.workflow.sleep" :: Text)], "fired") insertGcTimerStmt - Right beforeCounts <- Store.runStoreIO storeHandle $ workflowOwnedRowCounts "gc-basic" "gb-1" - beforeCounts `shouldBe` (1, 3, 1, 0, 1, 1) - Right freshSummary <- - Store.runStoreIO storeHandle $ - WorkflowGc.gcWorkflowsOnce - now - WorkflowGc.WorkflowGcPolicy{retention = 3600, batchSize = 10} - freshSummary `shouldBe` WorkflowGc.WorkflowGcSummary{scanned = 0, deleted = 0} - Right (Just _) <- Store.runStoreIO storeHandle $ Store.lookupStreamId gcStreamName - Right deletedSummary <- - Store.runStoreIO storeHandle $ - WorkflowGc.gcWorkflowsOnce - (addUTCTime 1 now) - WorkflowGc.WorkflowGcPolicy{retention = 0, batchSize = 10} - deletedSummary `shouldBe` WorkflowGc.WorkflowGcSummary{scanned = 1, deleted = 1} - Right Nothing <- Store.runStoreIO storeHandle $ Store.lookupStreamId gcStreamName - Right afterCounts <- Store.runStoreIO storeHandle $ workflowOwnedRowCounts "gc-basic" "gb-1" - afterCounts `shouldBe` (0, 0, 0, 0, 0, 0) - - it "deletes scheduled sleep timers so a collected workflow cannot resurrect" $ \storeHandle -> do - counter <- newIORef (0 :: Int) - let name = WorkflowName "gc-scheduled-sleep" - wid = WorkflowId "gss-1" - journalStream = workflowGenerationStreamName name wid 0 - TimerId timerUuid = sleepTimerId name wid 0 "sleep:wait" - body = do - _ <- step (StepName "before-sleep") (liftIO (incrementAndRead counter)) - sleepNamed (StepName "wait") 3600 - Right Suspended <- - Store.runStoreIO storeHandle $ - runWorkflow name wid body - Right timerBeforeGc <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ - Tx.statement timerUuid sleepTimerStatusStmt - fmap fst timerBeforeGc `shouldBe` Just "scheduled" - - cancelledAt <- getCurrentTime - Right () <- - Store.runStoreIO storeHandle $ - appendJournalEntry name wid (WorkflowCancelled cancelledAt) - gcClock <- getCurrentTime - Right collected <- - Store.runStoreIO storeHandle $ - WorkflowGc.gcWorkflowsOnce - (addUTCTime 1 gcClock) - WorkflowGc.WorkflowGcPolicy{retention = 0, batchSize = 10} - collected `shouldBe` WorkflowGc.WorkflowGcSummary{scanned = 1, deleted = 1} - - Right Nothing <- Store.runStoreIO storeHandle $ Instance.lookupInstance name wid - Right Nothing <- Store.runStoreIO storeHandle $ Store.lookupStreamId journalStream - Right timerAfterGc <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ - Tx.statement timerUuid sleepTimerStatusStmt - timerAfterGc `shouldBe` Nothing - - Right noClaim <- - Store.runStoreIO storeHandle $ - runWorkflowTimerWorker Nothing (addUTCTime 7200 gcClock) (\_ -> pure Nothing) - noClaim `shouldBe` Nothing - Right Nothing <- Store.runStoreIO storeHandle $ Instance.lookupInstance name wid - Right Nothing <- Store.runStoreIO storeHandle $ Store.lookupStreamId journalStream - readIORef counter >>= (`shouldBe` 1) - - it "cancels a sleep fire when a terminal instance survives partial GC" $ \storeHandle -> do - let name = WorkflowName "gc-terminal-fire" - wid = WorkflowId "gtf-1" - full = "sleep:wait" - timerId@(TimerId timerUuid) = sleepTimerId name wid 0 full - journalStream = workflowGenerationStreamName name wid 0 - now <- getCurrentTime - Right () <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ do - Instance.upsertInstanceTx "gtf-1" "gc-terminal-fire" 0 Instance.WfCancelled Nothing - void $ - scheduleTimerOnceTx - TimerRequest - { timerId - , processManagerName = "gc-terminal-fire" - , correlationId = "gtf-1" - , fireAt = now - , payload = sleepTimerPayload 0 full - } - Right (Just claimed) <- - Store.runStoreIO storeHandle $ - runWorkflowTimerWorker Nothing now (\_ -> pure Nothing) - claimed ^. #timerId `shouldBe` timerId - Right terminalTimer <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ - Tx.statement timerUuid sleepTimerStatusStmt - fmap fst terminalTimer `shouldBe` Just "cancelled" - Right Nothing <- Store.runStoreIO storeHandle $ Store.lookupStreamId journalStream - Right resolved <- - Store.runStoreIO storeHandle $ - stepExists name wid 0 full - resolved `shouldBe` False - - it "keeps completed children while a parent is live and converges after partial cleanup" $ \storeHandle -> do - let parentName = WorkflowName "gc-live-parent" - parentId = WorkflowId "gp-1" - childName = WorkflowName "gc-child" - childId = WorkflowId "gc-1" - now <- getCurrentTime - Right () <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ do - Instance.upsertInstanceTx "gp-1" "gc-live-parent" 0 Instance.WfRunning Nothing - Child.registerChildTx "gc-1" "gc-child" "gp-1" "gc-live-parent" "child:gc-1:result" - void (Child.markChildResultTx "gc-1" "gc-child" (toJSON ("ok" :: Text)) now) - Right () <- - Store.runStoreIO storeHandle $ - appendJournalEntry childName childId (WorkflowCompleted now) - Right held <- - Store.runStoreIO storeHandle $ - WorkflowGc.gcWorkflowsOnce - (addUTCTime 1 now) - WorkflowGc.WorkflowGcPolicy{retention = 0, batchSize = 10} - held `shouldBe` WorkflowGc.WorkflowGcSummary{scanned = 0, deleted = 0} - Right childStillThere <- Store.runStoreIO storeHandle $ Store.lookupStreamId (workflowGenerationStreamName childName childId 0) - childStillThere `shouldSatisfy` isJust - Right () <- - Store.runStoreIO storeHandle $ - appendJournalEntry parentName parentId (WorkflowCompleted now) - Right () <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ - Tx.statement ("gc-1", "gc-child") deleteGcStepsStmt - Right collected <- - Store.runStoreIO storeHandle $ - WorkflowGc.gcWorkflowsOnce - (addUTCTime 1 now) - WorkflowGc.WorkflowGcPolicy{retention = 0, batchSize = 10} - collected `shouldBe` WorkflowGc.WorkflowGcSummary{scanned = 2, deleted = 2} - Right parentGone <- Store.runStoreIO storeHandle $ Instance.lookupInstance parentName parentId - parentGone `shouldBe` Nothing - Right childGone <- Store.runStoreIO storeHandle $ Instance.lookupInstance childName childId - childGone `shouldBe` Nothing - Right childRows <- Store.runStoreIO storeHandle $ workflowOwnedChildCount "gc-child" "gc-1" - childRows `shouldBe` 0 - -{- | Increment a shared counter and return its new value (the step's side -effect, so replay can be proven by watching the counter). --} -incrementAndRead :: IORef Int -> IO Int -incrementAndRead ref = atomicModifyIORef' ref (\n -> (n + 1, n + 1)) - -forceWorkflowLeaseStmt :: Statement (Text, Text, Text, UTCTime) () -forceWorkflowLeaseStmt = - preparable - """ - UPDATE keiro.keiro_workflows - SET leased_by = $3, - lease_expires_at = $4, - updated_at = now() - WHERE workflow_id = $1 - AND workflow_name = $2 - """ - ( contrazip4 - (E.param (E.nonNullable E.text)) - (E.param (E.nonNullable E.text)) - (E.param (E.nonNullable E.text)) - (E.param (E.nonNullable E.timestamptz)) - ) - D.noResult - -{- | Six numbered steps, each returning its index after bumping a shared -counter. The counter lets a re-hydration prove the steps short-circuit -(it stays at 6 when every step is replayed from the journal/snapshot). --} -countingSixSteps :: (Workflow :> es, IOE :> es) => IORef Int -> Eff es [Int] -countingSixSteps counter = - mapM - (\i -> step (StepName ("s" <> Text.pack (show i))) (liftIO (incrementAndRead counter) >> pure i)) - [1 .. 6] - -newtype Approx = Approx Double - deriving stock (Eq, Show) - -instance ToJSON Approx where - toJSON (Approx d) = toJSON (round d :: Int) - -instance FromJSON Approx where - parseJSON value = do - n <- Aeson.parseJSON value - pure (Approx (fromIntegral (n :: Int))) - -data RejectingRoundTrip = RejectingRoundTrip - deriving stock (Eq, Show) - -instance ToJSON RejectingRoundTrip where - toJSON RejectingRoundTrip = Aeson.String "not-an-object" - -instance FromJSON RejectingRoundTrip where - parseJSON = Aeson.withObject "RejectingRoundTrip" $ \_ -> pure RejectingRoundTrip - -{- | A distinguished exception used to simulate a process crash mid-workflow -(after a step has committed its journal append but before completion). --} -data SimulatedCrash = SimulatedCrash - deriving stock (Show) - -instance Exception SimulatedCrash - -{- | A three-step workflow; each step bumps a shared counter so a resume can -prove steps short-circuit (the counter only advances for steps that run). --} -threeStep :: (Workflow :> es, IOE :> es) => IORef Int -> Eff es (Int, Int, Int) -threeStep counter = do - a <- step (StepName "s1") (liftIO (incrementAndRead counter)) - b <- step (StepName "s2") (liftIO (incrementAndRead counter)) - c <- step (StepName "s3") (liftIO (incrementAndRead counter)) - pure (a, b, c) - -threeStepThenSignal :: (Workflow :> es, IOE :> es) => IORef Int -> MVar () -> Eff es (Int, Int, Int) -threeStepThenSignal counter done = do - result <- threeStep counter - liftIO (putMVar done ()) - pure result - -{- | Runs step @"s1"@ (which commits its own journal append) then crashes, so -the journal is left with one StepRecorded and no WorkflowCompleted. --} -crashAfterStep1 :: (Workflow :> es, IOE :> es) => IORef Int -> Eff es (Int, Int, Int) -crashAfterStep1 counter = do - _ <- step (StepName "s1") (liftIO (incrementAndRead counter)) - _ <- liftIO (throwIO SimulatedCrash) - pure (0, 0, 0) - -{- | A workflow with one durable side effect before a switchable failure and -one durable side effect after it. Resurrection tests use the counter to prove -the recorded prefix never executes again. --} -recoverableWorkflow :: - (Workflow :> es, IOE :> es) => - IORef Bool -> - IORef Int -> - Eff es Int -recoverableWorkflow shouldCrash counter = do - _ <- step (StepName "durable-prefix") (liftIO (incrementAndRead counter)) - crashing <- liftIO (readIORef shouldCrash) - when crashing (liftIO (throwIO SimulatedCrash)) - step (StepName "durable-tail") (liftIO (incrementAndRead counter)) - -{- | Awaits an external step, then runs a step that bumps the counter. Used to -prove the resume worker drives a suspended workflow to completion once its -awaited step is journaled. --} -awaitingThenStep :: (Workflow :> es, IOE :> es) => IORef Int -> Eff es Text -awaitingThenStep counter = do - decision <- awaitStep (StepName "awk:approval") (pure ()) - _ <- step (StepName "use") (liftIO (incrementAndRead counter) >> pure (decision <> "!")) - pure (decision <> "-done") - -{- | A rolling-total workflow (EP-48 continue-as-new acceptance). It adds @total@ -unit-valued work steps to a running total, rotating its journal every -@rotateEvery@ steps via 'continueAsNew'. The carried seed is the pair -@(runningTotal, stepsDoneGlobally)@ so each generation knows the global -progress; @genDone@ counts steps within the /current/ generation to bound it. -Each work step bumps @counter@ exactly once (proving rotation neither drops -nor double-counts) and returns 1, so the final total equals @total@. - -Step names are the global step index (@w0@, @w1@, …), so they are unique -within each generation's journal and replay-stable. Note the regression -direction: on a tree where 'continueAsNew' did not rotate, this body would put -all @total@ steps on generation 0's single journal and the per-generation -@<= K@ bound below would fail for @total > K@. --} -rollingTotal :: (Workflow :> es, IOE :> es) => IORef Int -> Int -> Int -> Eff es Int -rollingTotal counter rotateEvery total = do - (acc0, done0) <- restoreSeed (0 :: Int, 0 :: Int) - go acc0 done0 0 - where - go acc done genDone - | done >= total = pure acc -- all global work done: this generation completes - | genDone >= rotateEvery = continueAsNew (acc, done) -- bound this generation; carry onward - | otherwise = do - n <- - step - (StepName ("w" <> Text.pack (show done))) - (liftIO (modifyIORef' counter (+ 1) >> pure (1 :: Int))) - go (acc + n) (done + 1) (genDone + 1) - --- The patch id under test (EP-49). -fraudPatchId :: PatchId -fraudPatchId = PatchId "fraud-check-v2" - -{- | The workflow BEFORE the patch shipped: reserve, then await an external step -(so an instance can be left in flight, mid-journal, with one ordinary step -recorded and no completion). Used to create the in-flight instance. --} -prePatchWorkflow :: (Workflow :> es, IOE :> es) => IORef Int -> Eff es Text -prePatchWorkflow counter = do - _ <- step (StepName "reserve-inventory") (liftIO (incrementAndRead counter) >> pure ()) - (_ :: ()) <- awaitStep (StepName "awk:gate") (pure ()) -- park here, in flight - pure "old-done" - -{- | The workflow AFTER the patch shipped: the same first step, then a -patch-gated cross-cutting branch. The in-flight instance (which already -journaled reserve-inventory under the pre-patch code) must observe False and -take the OLD branch; a fresh instance must observe True and take the NEW branch. --} -postPatchWorkflow :: (Workflow :> es, IOE :> es) => IORef Int -> Eff es Text -postPatchWorkflow counter = do - _ <- step (StepName "reserve-inventory") (liftIO (incrementAndRead counter) >> pure ()) - useNew <- patch fraudPatchId - if useNew - then step (StepName "new-charge") (pure "new-branch") - else step (StepName "old-charge") (pure "old-branch") - -postPatchAfterSuspendWorkflow :: (Workflow :> es, IOE :> es) => IORef Int -> Eff es Text -postPatchAfterSuspendWorkflow counter = do - _ <- step (StepName "reserve-inventory") (liftIO (incrementAndRead counter) >> pure ()) - (_ :: ()) <- awaitStep (StepName "awk:gate") (pure ()) - useNew <- patch fraudPatchId - if useNew - then step (StepName "new-charge") (pure "new-branch") - else step (StepName "old-charge") (pure "old-branch") - -prePatchWakeOnlyWorkflow :: (Workflow :> es) => Eff es Text -prePatchWakeOnlyWorkflow = do - (_ :: ()) <- awaitStep (StepName "awk:gate") (pure ()) - pure "old-done" - -postPatchWakeOnlyWorkflow :: (Workflow :> es) => Eff es Text -postPatchWakeOnlyWorkflow = do - (_ :: ()) <- awaitStep (StepName "awk:gate") (pure ()) - useNew <- patch fraudPatchId - if useNew - then step (StepName "new-charge") (pure "new-branch") - else step (StepName "old-charge") (pure "old-branch") - -rotatingPatchWorkflow :: (Workflow :> es) => Eff es Text -rotatingPatchWorkflow = do - seed <- restoreSeed (0 :: Int) - if seed < 1 - then continueAsNew (seed + 1) - else do - useNew <- patch fraudPatchId - if useNew - then step (StepName "new-charge") (pure "new-branch") - else step (StepName "old-charge") (pure "old-branch") - -{- | A workflow (EP-50 push tests) that awaits an external "awk:gate" step, then -runs a step that fills @done@ — so a test can observe the exact moment the -workflow resumes to completion. Awaiting first means the journal is empty until -the external gate append, which is what makes the instance discoverable by the -resume worker (the gate's StepRecorded is the first index row). --} -gateThenSignal :: (Workflow :> es, IOE :> es) => MVar () -> Eff es Text -gateThenSignal done = do - (_ :: ()) <- awaitStep (StepName "awk:gate") (pure ()) - _ <- step (StepName "after-gate") (liftIO (putMVar done ()) >> pure ()) - pure "resumed" - --- | A two-step workflow whose steps each bump a shared counter. -demoWorkflow :: (Workflow :> es, IOE :> es) => IORef Int -> Eff es (Int, Int) -demoWorkflow counter = do - a <- step (StepName "first") (liftIO (incrementAndRead counter)) - b <- step (StepName "second") (liftIO (incrementAndRead counter)) - pure (a, b) - -{- | A workflow that immediately awaits a step nothing ever arms — used to -exercise the suspend path and external completion. --} -neverArmingWorkflow :: (Workflow :> es) => Eff es Int -neverArmingWorkflow = awaitStep (StepName "awk:test") (pure ()) - -{- | The awakeable validation workflow: allocate a durable promise, suspend on -it, and (once signalled) append "!" to the payload through a recorded step. --} -approvalFlowWithId :: (Workflow :> es, Store :> es, IOE :> es) => IORef (Maybe AwakeableId) -> Eff es Text -approvalFlowWithId ref = do - (aid, await) <- awakeableNamed (StepName "approval") - liftIO (writeIORef ref (Just aid)) - v <- await - step (StepName "use") (pure (v <> "!")) - -publishAwakeableBeforeAwait :: - forall es. - (Workflow :> es, Store :> es, IOE :> es) => - IORef (Maybe AwakeableId) -> - Eff es () -publishAwakeableBeforeAwait ref = do - (aid, _await :: Eff es Text) <- awakeableNamed (StepName "gate") - _ <- - step (StepName "publish") $ do - liftIO (writeIORef ref (Just aid)) - (_ :: ()) <- awaitStep (StepName "hold") (pure ()) - pure () - -awaitPublishedAwakeable :: - (Workflow :> es, Store :> es, IOE :> es) => - IORef (Maybe AwakeableId) -> - Eff es Text -awaitPublishedAwakeable ref = do - (aid, await) <- awakeableNamed (StepName "gate") - _ <- - step (StepName "publish") $ do - liftIO (writeIORef ref (Just aid)) - await - -snapshotUnsignalledAwakeable :: - (Workflow :> es, Store :> es, IOE :> es) => - IORef (Maybe AwakeableId) -> - Eff es Text -snapshotUnsignalledAwakeable ref = do - (aid, await) <- awakeableNamed (StepName "gate") - liftIO (writeIORef ref (Just aid)) - await - -snapshotShadowedAwakeable :: (Workflow :> es, Store :> es, IOE :> es) => Eff es Text -snapshotShadowedAwakeable = do - (aid, await) <- awakeableNamed (StepName "gate") - _ <- step (StepName "mid") (void (signalAwakeable aid ("payload" :: Text))) - await - -snapshotStaleAwakeablePhaseOne :: - forall es. - (Workflow :> es, Store :> es, IOE :> es) => - IORef (Maybe AwakeableId) -> - Eff es () -snapshotStaleAwakeablePhaseOne ref = do - (aid, _await :: Eff es Text) <- awakeableNamed (StepName "gate") - liftIO (writeIORef ref (Just aid)) - _ <- step (StepName "mid") (void (signalAwakeable aid ("payload" :: Text))) - (_ :: ()) <- awaitStep (StepName "hold") (pure ()) - pure () - -snapshotStaleAwakeablePhaseTwo :: (Workflow :> es, Store :> es, IOE :> es) => Eff es Text -snapshotStaleAwakeablePhaseTwo = do - (_aid, await) <- awakeableNamed (StepName "gate") - _ <- step (StepName "mid") (pure ()) - await - -snapshotStaleChildPhaseOne :: - (Workflow :> es, Store :> es, IOE :> es, Error Store.StoreError :> es) => - WorkflowId -> - Eff es () -snapshotStaleChildPhaseOne childWid = do - _h <- spawnChild (WorkflowName "snapshot-child") childWid shipWorkflow - _ <- - step (StepName "drive") $ - void (runChildWorkflow defaultWorkflowRunOptions (WorkflowName "snapshot-child") childWid shipWorkflow) - (_ :: ()) <- awaitStep (StepName "hold") (pure ()) - pure () - -snapshotStaleChildPhaseTwo :: - (Workflow :> es, Store :> es, IOE :> es) => - WorkflowId -> - Eff es Text -snapshotStaleChildPhaseTwo childWid = do - h <- spawnChild (WorkflowName "snapshot-child") childWid shipWorkflow - _ <- step (StepName "drive") (pure ()) - awaitChild h - -readRequiredAwakeableId :: IORef (Maybe AwakeableId) -> IO AwakeableId -readRequiredAwakeableId ref = - readIORef ref >>= \case - Just aid -> pure aid - Nothing -> fail "workflow did not allocate an awakeable id" - -uuidLiteral :: String -> UUID -uuidLiteral raw = - case fromString raw of - Just uuid -> uuid - Nothing -> error ("invalid UUID literal in test: " <> raw) - -{- | A two-step workflow with a durable sleep between the steps. The sleep's -name and delay are parameters so one helper drives both the zero-delta and -the real-time tests. --} -sleepDemoNamed :: - (Workflow :> es, Store :> es, IOE :> es) => - IORef Int -> StepName -> NominalDiffTime -> Eff es (Int, Int) -sleepDemoNamed counter sName delta = do - a <- step (StepName "a") (liftIO (incrementAndRead counter)) - sleepNamed sName delta - b <- step (StepName "b") (liftIO (incrementAndRead counter)) - pure (a, b) - -rollingSleepWorkflow :: - (Workflow :> es, Store :> es, IOE :> es) => - IORef Int -> Eff es Int -rollingSleepWorkflow counter = do - seed <- restoreSeed (0 :: Int) - _ <- step (StepName "work") (liftIO (incrementAndRead counter)) - if seed < 2 - then sleepNamed (StepName "cool") 0 >> continueAsNew (seed + 1) - else pure seed - -rollingAwakeableWorkflow :: - (Workflow :> es, Store :> es, IOE :> es) => - IORef [AwakeableId] -> Eff es Text -rollingAwakeableWorkflow idsRef = do - seed <- restoreSeed (0 :: Int) - (aid, await) <- awakeableNamed (StepName "gate") - liftIO (modifyIORef' idsRef (\ids -> if aid `elem` ids then ids else ids <> [aid])) - value <- await - if seed < 1 - then continueAsNew (seed + 1) - else step (StepName "use") (pure value) - -rotatingParentWorkflow :: - (Workflow :> es, Store :> es, IOE :> es) => - WorkflowId -> Eff es Text -rotatingParentWorkflow childWid = do - seed <- restoreSeed (0 :: Int) - h <- spawnChild (WorkflowName "ship") childWid shipWorkflow - result <- awaitChild h - if seed < 1 - then continueAsNew (seed + 1) - else pure result - -failedChildBeforeRotation :: - (Workflow :> es, Store :> es) => - WorkflowId -> - Eff es Text -failedChildBeforeRotation childWid = do - _ <- spawnChild (WorkflowName "ship") childWid shipWorkflow - awaitStep (StepName "rotation-gate") (pure ()) - -rotatePastFailedChild :: - (Workflow :> es, Store :> es) => - WorkflowId -> - Eff es Text -rotatePastFailedChild childWid = do - _ <- spawnChild (WorkflowName "ship") childWid shipWorkflow - continueAsNew () - -catchFailedChildAfterRotation :: - (Workflow :> es, Store :> es, IOE :> es) => - WorkflowId -> - Eff es Text -catchFailedChildAfterRotation childWid = do - child <- spawnChild (WorkflowName "ship") childWid shipWorkflow - EffException.catch - (awaitChild child) - (\(WorkflowChildFailed _ _ reason) -> pure reason) - -{- | A workflow that records one step, then suspends on an await — so it has a -step row but no completion marker (the unfinished-discovery case). --} -stepThenAwaitWorkflow :: (Workflow :> es, IOE :> es) => IORef Int -> Eff es Int -stepThenAwaitWorkflow counter = do - _ <- step (StepName "s1") (liftIO (incrementAndRead counter)) - awaitStep (StepName "awk:wait") (pure ()) - --- | A two-step child workflow used in the child-workflow tests. -shipWorkflow :: (Workflow :> es) => Eff es Text -shipWorkflow = do - a <- step (StepName "pack") (pure ("packed" :: Text)) - b <- step (StepName "label") (pure (a <> "+labelled")) - pure b - -{- | A parent that spawns a @"ship"@ child (id supplied), awaits its result, and -then records a @notify@ step. Parametrised by child id so each test isolates -its own child journal. --} -parentWorkflow :: (Workflow :> es, Store :> es, IOE :> es) => WorkflowId -> Eff es Text -parentWorkflow childWid = do - h <- spawnChild (WorkflowName "ship") childWid shipWorkflow - result <- awaitChild h - _ <- step (StepName "notify") (pure ("done:" <> result)) - pure ("done:" <> result) - -jsonObjectChildWorkflow :: Eff es Aeson.Value -jsonObjectChildWorkflow = - pure (object ["cancelled" Aeson..= True]) - -jsonObjectParentWorkflow :: (Workflow :> es, Store :> es, IOE :> es) => WorkflowId -> Eff es Aeson.Value -jsonObjectParentWorkflow childWid = do - h <- spawnChild (WorkflowName "json-child") childWid jsonObjectChildWorkflow - result <- awaitChild h - _ <- step (StepName "json-notify") (pure ()) - pure result - -selfCancellingWorkflow :: (Workflow :> es, Store :> es, IOE :> es) => WorkflowName -> WorkflowId -> IORef Int -> Eff es Int -selfCancellingWorkflow name wid counter = do - _ <- step (StepName "one") (liftIO (incrementAndRead counter)) - _ <- - step (StepName "two") $ do - now <- liftIO getCurrentTime - appendJournalEntry name wid (WorkflowCancelled now) - liftIO (incrementAndRead counter) - step (StepName "three") (liftIO (incrementAndRead counter)) - -nominalDays :: Int -> NominalDiffTime -nominalDays n = fromIntegral n * 86400 - -attrKeyText :: AttributeKey Text -> Text -attrKeyText = unkey - -attrKeyTextInt64 :: AttributeKey Int64 -> Text -attrKeyTextInt64 = unkey - -textAttr :: Attributes -> Text -> Maybe Text -textAttr attrs name = case lookupAttribute attrs name of - Just (AttributeValue (TextAttribute t)) -> Just t - _ -> Nothing - -intAttr :: Attributes -> Text -> Maybe Int64 -intAttr attrs name = case lookupAttribute attrs name of - Just (AttributeValue (IntAttribute n)) -> Just n - _ -> Nothing - -{- | A frozen snapshot of an 'ImmutableSpan'. In hs-opentelemetry 1.0 the -mutable span fields (name, attributes, status) live behind the -@spanHot :: IORef SpanHot@ field rather than directly on 'ImmutableSpan', -so the tests read that reference once after the span ends and assert on -this flat record. --} -data CapturedSpan = CapturedSpan - { csName :: Text - , csKind :: SpanKind - , csAttributes :: Attributes - , csStatus :: SpanStatus - , csContext :: SpanContext - , csParent :: Maybe Span - } - -captureSpan :: ImmutableSpan -> IO CapturedSpan -captureSpan sp = do - hot <- readIORef (spanHot sp) - pure - CapturedSpan - { csName = hotName hot - , csKind = spanKind sp - , csAttributes = hotAttributes hot - , csStatus = hotStatus hot - , csContext = spanContext sp - , csParent = spanParent sp - } - -{- | Tiny in-process \"Kafka topic\": an MVar of consumed records plus an -incrementing offset. The publisher pushes records here; the consumer -drains the MVar. There is no real broker — the goal of the fixture is -to validate that the keiro envelope and outbox/inbox semantics -compose correctly across two isolated PostgreSQL contexts. --} -newtype KafkaTopic = KafkaTopic (MVar (Int64, [InboxKafka.KafkaInboundRecord])) - -newKafkaTopic :: IO KafkaTopic -newKafkaTopic = KafkaTopic <$> newMVar (0, []) - -kafkaTopicAccept :: (MonadIO m) => KafkaTopic -> OutboxRow -> m () -kafkaTopicAccept (KafkaTopic ref) row = liftIO $ do - let record = OutboxKafka.outboxRowToKafkaRecord row - headersText = - [ (TE.decodeUtf8 name, TE.decodeUtf8 value) - | (name, value) <- record ^. #headers - ] - now <- getCurrentTime - modifyMVar ref $ \(nextOffset, acc) -> - let inbound = - InboxKafka.KafkaInboundRecord - { topic = record ^. #topic - , partition = 0 - , offset = nextOffset - , key = fmap TE.decodeUtf8 (record ^. #key) - , payload = record ^. #payload - , headers = headersText - , receivedAt = now - } - in pure ((nextOffset + 1, inbound : acc), ()) - -kafkaTopicPublish :: - forall es. - (IOE :> es) => - KafkaTopic -> - OutboxRow -> - Eff es PublishOutcome -kafkaTopicPublish topic row = do - kafkaTopicAccept topic row - pure PublishSucceeded - -perRow :: - (OutboxRow -> Eff es PublishOutcome) -> - [OutboxRow] -> - Eff es [(OutboxId, PublishOutcome)] -perRow publish rows = - traverse publishOne rows - where - publishOne row = do - outcome <- publish row - pure (row ^. #outboxId, outcome) - -drainKafkaTopic :: KafkaTopic -> IO [InboxKafka.KafkaInboundRecord] -drainKafkaTopic (KafkaTopic ref) = do - (_, acc) <- readMVar ref - pure (reverse acc) - -redeliverWithDifferentOffset :: - InboxKafka.KafkaInboundRecord -> - InboxKafka.KafkaInboundRecord -redeliverWithDifferentOffset record = record & #offset .~ (record ^. #offset) + 1000 - -data ConsumeResult a - = ConsumeDecodeFailed !InboxKafka.KafkaDecodeError - | ConsumePolicyUnsatisfied !InboxError - | ConsumeApplied !(InboxResult a) - deriving stock (Eq, Show) - -{- | A worker-shaped consumer: decode the Kafka record into an -IntegrationEvent and run it through the inbox. --} -consumeAndApply :: - forall es. - (IOE :> es, Store :> es) => - InboxKafka.KafkaInboundRecord -> - (IntegrationEvent -> Tx.Transaction ()) -> - Eff es (ConsumeResult ()) -consumeAndApply record handler = - case InboxKafka.integrationEventFromKafka record of - Left err -> pure (ConsumeDecodeFailed err) - Right (event, kafkaRef) -> do - result <- - runInboxTransaction Nothing PreferIntegrationMessageId event (Just kafkaRef) handler - case result of - Left err -> pure (ConsumePolicyUnsatisfied err) - Right applied -> pure (ConsumeApplied applied) - -billingReactionHandler :: IntegrationEvent -> Tx.Transaction () -billingReactionHandler event = case decodeJsonIntegrationEvent event of - Left _ -> Tx.condemn - Right (OrderSubmittedPayload orderId quantity) -> - Tx.statement (orderId, fromIntegral quantity :: Int64) insertReceivedOrderStmt - -loggingReactionHandler :: Text -> IntegrationEvent -> Tx.Transaction () -loggingReactionHandler _ event = do - -- The cross-context test only needs the (eventType, key) pair, not - -- the decoded payload. - let key = fromMaybe "" (event ^. #key) - Tx.statement (event ^. #source, event ^. #eventType, key) appendBillingEventLogStmt - -insertReceivedOrderStmt :: Statement (Text, Int64) () -insertReceivedOrderStmt = - preparable - """ - INSERT INTO billing_received_orders (order_id, quantity) VALUES ($1, $2) - ON CONFLICT (order_id) DO NOTHING - """ - ( contrazip2 - (E.param (E.nonNullable E.text)) - (E.param (E.nonNullable E.int8)) - ) - D.noResult - -billingReceivedOrdersCountStmt :: Statement () Int -billingReceivedOrdersCountStmt = - preparable - "SELECT COUNT(*)::bigint FROM billing_received_orders" - E.noParams - (D.singleRow (fromIntegral <$> D.column (D.nonNullable D.int8))) - -appendBillingEventLogStmt :: Statement (Text, Text, Text) () -appendBillingEventLogStmt = - preparable - "INSERT INTO billing_event_log (source, event_type, order_id) VALUES ($1, $2, $3)" - ( contrazip3 - (E.param (E.nonNullable E.text)) - (E.param (E.nonNullable E.text)) - (E.param (E.nonNullable E.text)) - ) - D.noResult - -billingEventLogStmt :: Statement () [(Text, Text)] -billingEventLogStmt = - preparable - "SELECT event_type, order_id FROM billing_event_log ORDER BY seq" - E.noParams - ( D.rowList - ( (,) - <$> D.column (D.nonNullable D.text) - <*> D.column (D.nonNullable D.text) - ) - ) - -orderSubmittedEnvelope :: Text -> Int -> Text -> IntegrationEvent -orderSubmittedEnvelope orderId quantity messageId = - encodeJsonIntegrationEvent - ( sampleIntegrationEnvelope - & #messageId - .~ messageId - & #eventType - .~ "OrderSubmitted" - & #key - .~ Just orderId - ) - (OrderSubmittedPayload orderId quantity) - -orderCancelledEnvelope :: Text -> Text -> IntegrationEvent -orderCancelledEnvelope orderId messageId = - sampleIntegrationEnvelope - & #messageId - .~ messageId - & #eventType - .~ "OrderCancelled" - & #key - .~ Just orderId - & #payloadBytes - .~ ("{\"orderId\":\"" <> TE.encodeUtf8 orderId <> "\"}") - & #contentType - .~ ApplicationJson - -inboxTestCounterInsertStmt :: Statement Text () -inboxTestCounterInsertStmt = - preparable - "INSERT INTO inbox_test_counter (message_id) VALUES ($1)" - (E.param (E.nonNullable E.text)) - D.noResult - -inboxTestCounterCountStmt :: Statement () Int -inboxTestCounterCountStmt = - preparable - "SELECT COUNT(*)::bigint FROM inbox_test_counter" - E.noParams - (D.singleRow (fromIntegral <$> D.column (D.nonNullable D.int8))) - -sampleProducer :: IntegrationProducer () -sampleProducer = - IntegrationProducer - { name = "ordering-integration-producer" - , source = "ordering" - , messageIdPrefix = "msg" - , mapEvent = \_recorded () -> Just sampleDraft - } - -sampleDraft :: IntegrationEventDraft -sampleDraft = - IntegrationEventDraft - { destination = "billing.orders.v1" - , key = Just "order-123" - , eventType = "OrderSubmitted" - , schemaVersion = 1 - , contentType = ApplicationJson - , schemaReference = Nothing - , sourceEventId = Nothing - , sourceGlobalPosition = Nothing - , payloadBytes = "{\"orderId\":\"order-123\",\"quantity\":5}" - , occurredAt = UTCTime (ModifiedJulianDay 60000) (secondsToDiffTime 0) - , causationId = Nothing - , correlationId = Nothing - , traceContext = Nothing - , attributes = Just (object ["source" Aeson..= ("test-suite" :: Text)]) - } - -sampleOutboxRow :: IntegrationEvent -> OutboxRow -sampleOutboxRow event = - OutboxRow - { outboxId = OutboxId outboxUuid1 - , event - , status = OutboxPending - , attemptCount = 0 - , nextAttemptAt = UTCTime (ModifiedJulianDay 60000) (secondsToDiffTime 0) - , lastError = Nothing - , publishedAt = Nothing - , createdAt = UTCTime (ModifiedJulianDay 60000) (secondsToDiffTime 0) - , updatedAt = UTCTime (ModifiedJulianDay 60000) (secondsToDiffTime 0) - } - -backdateOutboxUpdatedAt :: (Store :> es) => OutboxId -> UTCTime -> Eff es () -backdateOutboxUpdatedAt oid timestamp = - Store.runTransaction $ - Tx.statement (unOutboxId oid, timestamp) backdateOutboxUpdatedAtStmt - -backdateOutboxUpdatedAtStmt :: Statement (UUID, UTCTime) () -backdateOutboxUpdatedAtStmt = - preparable - "UPDATE keiro.keiro_outbox SET updated_at = $2 WHERE outbox_id = $1" - ( contrazip2 - (E.param (E.nonNullable E.uuid)) - (E.param (E.nonNullable E.timestamptz)) - ) - D.noResult - -backdateOutboxPublishedAt :: (Store :> es) => OutboxId -> UTCTime -> Eff es () -backdateOutboxPublishedAt oid timestamp = - Store.runTransaction $ - Tx.statement (unOutboxId oid, timestamp) backdateOutboxPublishedAtStmt - -backdateOutboxPublishedAtStmt :: Statement (UUID, UTCTime) () -backdateOutboxPublishedAtStmt = - preparable - "UPDATE keiro.keiro_outbox SET published_at = $2 WHERE outbox_id = $1" - ( contrazip2 - (E.param (E.nonNullable E.uuid)) - (E.param (E.nonNullable E.timestamptz)) - ) - D.noResult - -outboxUuid1, outboxUuid2, outboxUuid3, outboxUuid4 :: UUID -outboxUuid1 = case fromString "018f0f18-0000-7000-8000-000000000a01" of - Just uuid -> uuid - Nothing -> error "invalid outbox uuid 1" -outboxUuid2 = case fromString "018f0f18-0000-7000-8000-000000000a02" of - Just uuid -> uuid - Nothing -> error "invalid outbox uuid 2" -outboxUuid3 = case fromString "018f0f18-0000-7000-8000-000000000a03" of - Just uuid -> uuid - Nothing -> error "invalid outbox uuid 3" -outboxUuid4 = case fromString "018f0f18-0000-7000-8000-000000000a04" of - Just uuid -> uuid - Nothing -> error "invalid outbox uuid 4" - -outboxIdFromOrdinal :: Word64 -> OutboxId -outboxIdFromOrdinal n = - OutboxId (fromWords64 0x018f0f1800007000 (0x8000000000000000 + n)) - -uniqueIds :: (Eq a) => [a] -> [a] -uniqueIds = foldr (\x xs -> if x `elem` xs then xs else x : xs) [] - -data OrderSubmittedPayload = OrderSubmittedPayload - { orderId :: !Text - , quantity :: !Int - } - deriving stock (Generic, Eq, Show) - -instance ToJSON OrderSubmittedPayload where - toJSON = genericToJSON (aesonPrefix camelCase) - toEncoding = genericToEncoding (aesonPrefix camelCase) - -instance FromJSON OrderSubmittedPayload where - parseJSON = genericParseJSON (aesonPrefix camelCase) - -sampleIntegrationEnvelope :: IntegrationEvent -sampleIntegrationEnvelope = - IntegrationEvent - { messageId = "018f0f18-17aa-7000-8000-0000000000aa" - , source = "ordering" - , destination = "billing.orders.v1" - , key = Just "order-123" - , eventType = "OrderSubmitted" - , schemaVersion = 1 - , contentType = ApplicationJson - , schemaReference = - Just - SchemaReference - { registry = Just "https://schemas.example/registry" - , subject = Just "billing.orders.v1.OrderSubmitted" - , version = Just 1 - , schemaId = Just 42 - , fingerprint = Just "sha256:abc123" - } - , sourceEventId = Just (EventId integrationSourceEventUuid) - , sourceGlobalPosition = Just (GlobalPosition 42) - , payloadBytes = "{\"orderId\":\"order-123\",\"quantity\":5}" - , occurredAt = UTCTime (ModifiedJulianDay 60000) (secondsToDiffTime 0) - , causationId = Just (EventId integrationCausationUuid) - , correlationId = Just (EventId integrationCorrelationUuid) - , traceContext = - Just - TraceContext - { traceparent = "00-0af7651916cd43dd8448eb211c80319c-b7ad6b7169203331-01" - , tracestate = Just "rojo=00f067aa0ba902b7" - } - , attributes = Nothing - } - -integrationSourceEventUuid :: UUID -integrationSourceEventUuid = - case fromString "018f0f18-17aa-7000-8000-000000000003" of - Just uuid -> uuid - Nothing -> error "invalid integration source event UUID" - -integrationCausationUuid :: UUID -integrationCausationUuid = - case fromString "018f0f18-17aa-7000-8000-000000000004" of - Just uuid -> uuid - Nothing -> error "invalid integration causation UUID" - -integrationCorrelationUuid :: UUID -integrationCorrelationUuid = - case fromString "018f0f18-17aa-7000-8000-000000000005" of - Just uuid -> uuid - Nothing -> error "invalid integration correlation UUID" - -data OrderStream - -data OrderEvent - = OrderPlaced !Text !Int - deriving stock (Generic, Eq, Show) - -data OrderState - = Idle - deriving stock (Generic, Eq, Show) - -data OrderCommand - = PlaceOrder - deriving stock (Generic, Eq, Show) - -orderCodec :: Codec OrderEvent -orderCodec = - Codec - { eventTypes = EventType "OrderPlaced" :| [] - , eventType = \case - OrderPlaced{} -> EventType "OrderPlaced" - , schemaVersion = 2 - , encode = \case - OrderPlaced orderId quantity -> - object ["orderId" Aeson..= orderId, "quantity" Aeson..= quantity] - , decode = parseOrderPlaced - , upcasters = [(1, const upcastOrderPlacedV1)] - } - -gappyCodec :: Codec OrderEvent -gappyCodec = - Codec - { eventTypes = orderCodec ^. #eventTypes - , eventType = orderCodec ^. #eventType - , schemaVersion = 4 - , encode = orderCodec ^. #encode - , decode = orderCodec ^. #decode - , upcasters = [(1, const upcastOrderPlacedV1), (3, const Right)] - } - -parseOrderPlaced :: EventType -> Value -> Either Text OrderEvent -parseOrderPlaced _ value = - case parseEither parser value of - Right event -> Right event - Left message -> Left (fromStringLiteral message) - where - parser = withObject "OrderPlaced" $ \objectValue -> - OrderPlaced - <$> objectValue .: "orderId" - <*> objectValue .: "quantity" - -upcastOrderPlacedV1 :: Value -> Either Text Value -upcastOrderPlacedV1 value = - case parseEither parser value of - Right migrated -> Right migrated - Left message -> Left (fromStringLiteral message) - where - parser = withObject "OrderPlacedV1" $ \objectValue -> do - orderId <- objectValue .: "orderId" - quantity <- objectValue .: "qty" - pure (object ["orderId" Aeson..= (orderId :: Text), "quantity" Aeson..= (quantity :: Int)]) - -metadataForOrDie :: Int -> Maybe Value -> Value -metadataForOrDie version existing = - either (error . show) id (metadataFor version existing) - -emptyTransducer :: SymTransducer () '[] OrderState OrderCommand OrderEvent -emptyTransducer = - SymTransducer - { edgesOut = \_ -> [] - , initial = Idle - , initialRegs = RNil - , isFinal = \_ -> True - } - -type CounterEventStream = EventStream (HsPred '[] CounterCommand) '[] CounterState CounterCommand CounterEvent - -type ValidatedCounterEventStream = ValidatedEventStream (HsPred '[] CounterCommand) '[] CounterState CounterCommand CounterEvent - -type SnapshotCounterRegs = '[ '("lastAmount", Int)] - -type UninitializedSnapshotRegs = '[ '("initialized", Int), '("neverWritten", Int)] - -type SnapshotCounterEventStream = EventStream (HsPred SnapshotCounterRegs CounterCommand) SnapshotCounterRegs CounterState CounterCommand CounterEvent - -type PartialSnapshotEventStream = EventStream (HsPred SnapshotCounterRegs CounterCommand) SnapshotCounterRegs PartialSnapshotState CounterCommand CounterEvent - -type ValidatedSnapshotCounterEventStream = ValidatedEventStream (HsPred SnapshotCounterRegs CounterCommand) SnapshotCounterRegs CounterState CounterCommand CounterEvent - -type UninitializedSnapshotEventStream = EventStream (HsPred UninitializedSnapshotRegs CounterCommand) UninitializedSnapshotRegs CounterState CounterCommand CounterEvent - -data CounterCommand - = Add !Int - deriving stock (Generic, Eq, Show) - -data SkipCommand - = SAdd !Int - | SSkip - deriving stock (Generic, Eq, Show) - -data CounterEvent - = CounterAdded !Int - | CounterAudited !Int - deriving stock (Generic, Eq, Show) - -data CounterState - = Counting - deriving stock (Generic, Eq, Show, Enum, Bounded, Ord) - deriving anyclass (FromJSON, ToJSON) - -instance CanonicalStateShape CounterState - -data CounterStateV2 - = CountingV2 - | PausedV2 - deriving stock (Generic, Eq, Show, Enum, Bounded, Ord) - deriving anyclass (FromJSON, ToJSON) - -instance CanonicalStateShape CounterStateV2 - -data DrainState - = Draining - | Drained - deriving stock (Generic, Eq, Show, Enum, Bounded, Ord) - -data PartialSnapshotState - = SnapshotEncodable - | SnapshotEncodeBomb - deriving stock (Generic, Eq, Show, Enum, Bounded, Ord) - -instance CanonicalStateShape PartialSnapshotState - -instance ToJSON PartialSnapshotState where - toJSON SnapshotEncodable = Aeson.String "encodable" - toJSON SnapshotEncodeBomb = error "snapshot state encoder exploded" - -instance FromJSON PartialSnapshotState where - parseJSON = Aeson.withText "PartialSnapshotState" $ \case - "encodable" -> pure SnapshotEncodable - "bomb" -> pure SnapshotEncodeBomb - other -> fail ("unknown partial snapshot state: " <> Text.unpack other) - -counterEventStreamDef :: CounterEventStream -counterEventStreamDef = - EventStream - { transducer = counterTransducer - , initialState = Counting - , initialRegisters = RNil - , eventCodec = counterCodec - , resolveStreamName = Stream.streamName - , snapshotPolicy = Never - , stateCodec = Nothing - } - -counterEventStream :: ValidatedCounterEventStream -counterEventStream = mkEventStreamOrThrow "counter" counterEventStreamDef - -auditedCounterEventStream :: ValidatedCounterEventStream -auditedCounterEventStream = - mkEventStreamOrThrow - "counter-audited-only" - (counterEventStreamDef & #transducer .~ auditedCounterTransducer) - -auditedCounterTransducer :: SymTransducer (HsPred '[] CounterCommand) '[] CounterState CounterCommand CounterEvent -auditedCounterTransducer = - SymTransducer - { edgesOut = \case - Counting -> - [ Edge - { guard = matchInCtor addCtor - , update = UKeep - , output = [pack addCtor counterAuditedCtor (inpCtor addCtor #amount *: oNil)] - , target = Counting - , mode = Keiki.Live - } - ] - , initial = Counting - , initialRegs = RNil - , isFinal = \_ -> False - } - -noOpCounterEventStreamDef :: CounterEventStream -noOpCounterEventStreamDef = - counterEventStreamDef & #transducer .~ noOpCounterTransducer - -noOpCounterEventStream :: ValidatedCounterEventStream -noOpCounterEventStream = mkEventStreamOrThrow "counter-no-op" noOpCounterEventStreamDef - -counterTransducer :: SymTransducer (HsPred '[] CounterCommand) '[] CounterState CounterCommand CounterEvent -counterTransducer = - SymTransducer - { edgesOut = \case - Counting -> - [ Edge - { guard = matchInCtor addCtor - , update = UKeep - , output = [pack addCtor counterAddedCtor (inpCtor addCtor #amount *: oNil)] - , target = Counting - , mode = Keiki.Live - } - ] - , initial = Counting - , initialRegs = RNil - , isFinal = \_ -> False - } - -noOpCounterTransducer :: SymTransducer (HsPred '[] CounterCommand) '[] CounterState CounterCommand CounterEvent -noOpCounterTransducer = - SymTransducer - { edgesOut = \case - Counting -> - [ Edge - { guard = matchInCtor addCtor - , update = UKeep - , output = [] - , target = Counting - , mode = Keiki.Live - } - ] - , initial = Counting - , initialRegs = RNil - , isFinal = \_ -> False - } - -multiCounterEventStreamDef :: CounterEventStream -multiCounterEventStreamDef = - counterEventStreamDef & #transducer .~ multiCounterTransducer - -multiCounterEventStream :: ValidatedCounterEventStream -multiCounterEventStream = mkEventStreamOrThrow "counter-multi" multiCounterEventStreamDef - -multiCounterTransducer :: SymTransducer (HsPred '[] CounterCommand) '[] CounterState CounterCommand CounterEvent -multiCounterTransducer = - SymTransducer - { edgesOut = \case - Counting -> - [ Edge - { guard = matchInCtor addCtor - , update = UKeep - , output = - [ pack addCtor counterAddedCtor (inpCtor addCtor #amount *: oNil) - , pack addCtor counterAuditedCtor (inpCtor addCtor #amount *: oNil) - ] - , target = Counting - , mode = Keiki.Live - } - ] - , initial = Counting - , initialRegs = RNil - , isFinal = \_ -> False - } - -{- | Both guards match at runtime but remain outside keiki's conservative pure -overlap fragment. Distinct head event constructors keep inversion unambiguous, -so this is a validated stream that exercises the runtime step witness. --} -ambiguousCounterEventStreamDef :: CounterEventStream -ambiguousCounterEventStreamDef = - counterEventStreamDef & #transducer .~ ambiguousCounterTransducer - -ambiguousCounterEventStream :: ValidatedCounterEventStream -ambiguousCounterEventStream = - mkEventStreamOrThrow "counter-ambiguous" ambiguousCounterEventStreamDef - -ambiguousCounterTransducer :: SymTransducer (HsPred '[] CounterCommand) '[] CounterState CounterCommand CounterEvent -ambiguousCounterTransducer = - counterTransducer - { edgesOut = \case - Counting -> - [ Edge - { guard = ambiguousGuard - , update = UKeep - , output = [pack addCtor counterAddedCtor (inpCtor addCtor #amount *: oNil)] - , target = Counting - , mode = Keiki.Live - } - , Edge - { guard = ambiguousGuard - , update = UKeep - , output = [pack addCtor counterAuditedCtor (inpCtor addCtor #amount *: oNil)] - , target = Counting - , mode = Keiki.Live - } - ] - } - where - ambiguousGuard = PAnd (matchInCtor addCtor) (PNot PBot) - -snapshotCounterEventStreamDef :: SnapshotCounterEventStream -snapshotCounterEventStreamDef = - EventStream - { transducer = snapshotCounterTransducer - , initialState = Counting - , initialRegisters = RCons (Proxy @"lastAmount") 0 RNil - , eventCodec = counterCodec - , resolveStreamName = Stream.streamName - , snapshotPolicy = Every 2 - , stateCodec = Just (defaultStateCodec @SnapshotCounterRegs @CounterState 1) - } - -partialSnapshotEventStream :: ValidatedEventStream (HsPred SnapshotCounterRegs CounterCommand) SnapshotCounterRegs PartialSnapshotState CounterCommand CounterEvent -partialSnapshotEventStream = mkEventStreamOrThrow "partial-snapshot" partialSnapshotEventStreamDef - -partialSnapshotEventStreamDef :: PartialSnapshotEventStream -partialSnapshotEventStreamDef = - EventStream - { transducer = - SymTransducer - { edgesOut = \_ -> - [ Edge - { guard = matchInCtor addCtor - , update = - USet - (#lastAmount :: IndexN "lastAmount" SnapshotCounterRegs Int) - (inpCtor addCtor #amount) - , output = [pack addCtor counterAddedCtor (inpCtor addCtor #amount *: oNil)] - , target = SnapshotEncodeBomb - , mode = Keiki.Live - } - ] - , initial = SnapshotEncodable - , initialRegs = RCons (Proxy @"lastAmount") 0 RNil - , isFinal = \_ -> False - } - , initialState = SnapshotEncodable - , initialRegisters = RCons (Proxy @"lastAmount") 0 RNil - , eventCodec = counterCodec - , resolveStreamName = Stream.streamName - , snapshotPolicy = Every 1 - , stateCodec = Just (defaultStateCodec @SnapshotCounterRegs @PartialSnapshotState 1) - } - -uninitializedSnapshotEventStreamDef :: UninitializedSnapshotEventStream -uninitializedSnapshotEventStreamDef = - initializedSnapshotEventStreamDef - & #initialRegisters - .~ RCons (Proxy @"initialized") 0 (emptyRegFile @'[ '("neverWritten", Int)]) - -initializedSnapshotEventStreamDef :: UninitializedSnapshotEventStream -initializedSnapshotEventStreamDef = - EventStream - { transducer = - SymTransducer - { edgesOut = \case Counting -> [] - , initial = Counting - , initialRegs = RCons (Proxy @"initialized") 0 (RCons (Proxy @"neverWritten") 0 RNil) - , isFinal = \_ -> False - } - , initialState = Counting - , initialRegisters = RCons (Proxy @"initialized") 0 (RCons (Proxy @"neverWritten") 0 RNil) - , eventCodec = counterCodec - , resolveStreamName = Stream.streamName - , snapshotPolicy = Every 2 - , stateCodec = Just (defaultStateCodec @UninitializedSnapshotRegs @CounterState 1) - } - -snapshotCounterEventStream :: ValidatedSnapshotCounterEventStream -snapshotCounterEventStream = mkEventStreamOrThrow "snapshot-counter" snapshotCounterEventStreamDef - -snapshotCounterTransducer :: SymTransducer (HsPred SnapshotCounterRegs CounterCommand) SnapshotCounterRegs CounterState CounterCommand CounterEvent -snapshotCounterTransducer = - SymTransducer - { edgesOut = \case - Counting -> - [ Edge - { guard = matchInCtor addCtor - , update = - USet - (#lastAmount :: IndexN "lastAmount" SnapshotCounterRegs Int) - (inpCtor addCtor #amount) - , output = [pack addCtor counterAddedCtor (inpCtor addCtor #amount *: oNil)] - , target = Counting - , mode = Keiki.Live - } - ] - , initial = Counting - , initialRegs = RCons (Proxy @"lastAmount") 0 RNil - , isFinal = \_ -> False - } - -foldV1SnapshotCounterEventStream :: ValidatedSnapshotCounterEventStream -foldV1SnapshotCounterEventStream = - mkEventStreamOrThrow "snapshot-counter-fold-v1" foldV1SnapshotCounterEventStreamDef - -foldV1SnapshotCounterEventStreamDef :: SnapshotCounterEventStream -foldV1SnapshotCounterEventStreamDef = - snapshotCounterEventStreamDef - { transducer = foldV1SnapshotCounterTransducer - , stateCodec = - Just - ( defaultStateCodecWithFold - @SnapshotCounterRegs - @CounterState - (FoldVersion "fold-v1") - 1 - ) - } - -foldV2SnapshotCounterEventStream :: ValidatedSnapshotCounterEventStream -foldV2SnapshotCounterEventStream = - mkEventStreamOrThrow "snapshot-counter-fold-v2" foldV2SnapshotCounterEventStreamDef - -foldV2SnapshotCounterEventStreamDef :: SnapshotCounterEventStream -foldV2SnapshotCounterEventStreamDef = - foldV1SnapshotCounterEventStreamDef - { transducer = foldV2SnapshotCounterTransducer - , snapshotPolicy = Every 1 - , stateCodec = - Just - ( defaultStateCodecWithFold - @SnapshotCounterRegs - @CounterState - (FoldVersion "fold-v2") - 1 - ) - } - -foldV2WithoutFingerprintBumpEventStream :: ValidatedSnapshotCounterEventStream -foldV2WithoutFingerprintBumpEventStream = - mkEventStreamOrThrow - "snapshot-counter-fold-v2-without-fingerprint-bump" - foldV2WithoutFingerprintBumpEventStreamDef - -foldV2WithoutFingerprintBumpEventStreamDef :: SnapshotCounterEventStream -foldV2WithoutFingerprintBumpEventStreamDef = - foldV2SnapshotCounterEventStreamDef - { stateCodec = - Just - ( defaultStateCodecWithFold - @SnapshotCounterRegs - @CounterState - (FoldVersion "fold-v1") - 1 - ) - } - -foldV1SnapshotCounterTransducer :: SymTransducer (HsPred SnapshotCounterRegs CounterCommand) SnapshotCounterRegs CounterState CounterCommand CounterEvent -foldV1SnapshotCounterTransducer = - foldSnapshotCounterTransducer - (inpCtor addCtor #amount) - -foldV2SnapshotCounterTransducer :: SymTransducer (HsPred SnapshotCounterRegs CounterCommand) SnapshotCounterRegs CounterState CounterCommand CounterEvent -foldV2SnapshotCounterTransducer = - foldSnapshotCounterTransducer - (inpCtor addCtor #amount K..+ lit 1) - -foldSnapshotCounterTransducer :: - Keiki.Term SnapshotCounterRegs CounterCommand AddFields Int -> - SymTransducer (HsPred SnapshotCounterRegs CounterCommand) SnapshotCounterRegs CounterState CounterCommand CounterEvent -foldSnapshotCounterTransducer nextLastAmount = - SymTransducer - { edgesOut = \case - Counting -> - [ Edge - { guard = - PAnd - (matchInCtor addCtor) - (inpCtor addCtor #amount K..< lit 100) - , update = - USet - (#lastAmount :: IndexN "lastAmount" SnapshotCounterRegs Int) - nextLastAmount - , output = [pack addCtor counterAddedCtor (inpCtor addCtor #amount *: oNil)] - , target = Counting - , mode = Keiki.Live - } - , Edge - { guard = - PAnd - (matchInCtor addCtor) - ( PAnd - (inpCtor addCtor #amount K..>= lit 100) - ( inpCtor addCtor #amount - .== (proj (#lastAmount :: Keiki.Index SnapshotCounterRegs Int) K..+ lit 100) - ) - ) - , update = UKeep - , output = [pack addCtor counterAuditedCtor (inpCtor addCtor #amount *: oNil)] - , target = Counting - , mode = Keiki.Live - } - ] - , initial = Counting - , initialRegs = RCons (Proxy @"lastAmount") 0 RNil - , isFinal = \_ -> False - } - -multiSnapshotCounterEventStreamDef :: SnapshotCounterEventStream -multiSnapshotCounterEventStreamDef = - snapshotCounterEventStreamDef - & #transducer - .~ multiSnapshotCounterTransducer - & #snapshotPolicy - .~ Every 1 - -multiSnapshotCounterEventStream :: ValidatedSnapshotCounterEventStream -multiSnapshotCounterEventStream = mkEventStreamOrThrow "snapshot-counter-multi" multiSnapshotCounterEventStreamDef - -multiSnapshotCounterTransducer :: SymTransducer (HsPred SnapshotCounterRegs CounterCommand) SnapshotCounterRegs CounterState CounterCommand CounterEvent -multiSnapshotCounterTransducer = - SymTransducer - { edgesOut = \case - Counting -> - [ Edge - { guard = matchInCtor addCtor - , update = - USet - (#lastAmount :: IndexN "lastAmount" SnapshotCounterRegs Int) - (inpCtor addCtor #amount) - , output = - [ pack addCtor counterAddedCtor (inpCtor addCtor #amount *: oNil) - , pack addCtor counterAuditedCtor (inpCtor addCtor #amount *: oNil) - ] - , target = Counting - , mode = Keiki.Live - } - ] - , initial = Counting - , initialRegs = RCons (Proxy @"lastAmount") 0 RNil - , isFinal = \_ -> False - } - -guardedSnapshotCounterEventStreamDef :: SnapshotCounterEventStream -guardedSnapshotCounterEventStreamDef = - snapshotCounterEventStreamDef & #transducer .~ guardedSnapshotCounterTransducer - -guardedSnapshotCounterEventStream :: ValidatedSnapshotCounterEventStream -guardedSnapshotCounterEventStream = mkEventStreamOrThrow "snapshot-counter-guarded" guardedSnapshotCounterEventStreamDef - -guardedSnapshotCounterTransducer :: SymTransducer (HsPred SnapshotCounterRegs CounterCommand) SnapshotCounterRegs CounterState CounterCommand CounterEvent -guardedSnapshotCounterTransducer = - SymTransducer - { edgesOut = \case - Counting -> - [ Edge - { guard = - PAnd - (matchInCtor addCtor) - (inpCtor addCtor #amount .== proj (#lastAmount :: Keiki.Index SnapshotCounterRegs Int)) - , update = - USet - (#lastAmount :: IndexN "lastAmount" SnapshotCounterRegs Int) - (inpCtor addCtor #amount) - , output = [pack addCtor counterAddedCtor (inpCtor addCtor #amount *: oNil)] - , target = Counting - , mode = Keiki.Live - } - ] - , initial = Counting - , initialRegs = RCons (Proxy @"lastAmount") 0 RNil - , isFinal = \_ -> False - } - -{- | A deliberately replay-unsafe stream: its single edge is an ε-edge -(empty @output@) whose @update@ reads the command's @amount@. Because -the edge emits no event, that command field cannot be recovered on -replay, so keiki's hidden-input check flags it. Used to prove -'validateEventStream' / 'mkEventStream' reject an unsafe stream. --} -brokenHiddenInputEventStream :: SnapshotCounterEventStream -brokenHiddenInputEventStream = - snapshotCounterEventStreamDef & #transducer .~ brokenHiddenInputTransducer - -brokenHiddenInputTransducer :: SymTransducer (HsPred SnapshotCounterRegs CounterCommand) SnapshotCounterRegs CounterState CounterCommand CounterEvent -brokenHiddenInputTransducer = - SymTransducer - { edgesOut = \case - Counting -> - [ Edge - { guard = matchInCtor addCtor - , update = - USet - (#lastAmount :: IndexN "lastAmount" SnapshotCounterRegs Int) - (inpCtor addCtor #amount) - , output = [] - , target = Counting - , mode = Keiki.Live - } - ] - , initial = Counting - , initialRegs = RCons (Proxy @"lastAmount") 0 RNil - , isFinal = \_ -> False - } - -{- | A multi-event edge whose tail carries the command field omitted from its -head. The union of the outputs covers @amount@, but replay commits to an edge -by inverting only the head, so the stored chain cannot reconstruct @Add@. --} -headUnrecoverableEventStreamDef :: CounterEventStream -headUnrecoverableEventStreamDef = - counterEventStreamDef & #transducer .~ headUnrecoverableTransducer - -headUnrecoverableEventStream :: ValidatedCounterEventStream -headUnrecoverableEventStream = mkEventStreamUnchecked headUnrecoverableEventStreamDef - -headUnrecoverableTransducer :: SymTransducer (HsPred '[] CounterCommand) '[] CounterState CounterCommand CounterEvent -headUnrecoverableTransducer = - counterTransducer - { edgesOut = \case - Counting -> - [ Edge - { guard = matchInCtor addCtor - , update = UKeep - , output = - [ pack addCtor counterAddedCtor (Keiki.lit 0 *: oNil) - , pack addCtor counterAuditedCtor (inpCtor addCtor #amount *: oNil) - ] - , target = Counting - , mode = Keiki.Live - } - ] - } - -{- | Two edges share a head wire constructor, so one stored event can invert -through both. The double-negated guard is true at runtime but deliberately -outside keiki's pure overlap fragment, isolating the inversion warning from -the separate conservative determinism check. --} -inversionAmbiguousEventStreamDef :: CounterEventStream -inversionAmbiguousEventStreamDef = - counterEventStreamDef & #transducer .~ inversionAmbiguousTransducer - -inversionAmbiguousEventStream :: ValidatedCounterEventStream -inversionAmbiguousEventStream = - case mkEventStreamWith - Keiki.defaultValidationOptions{Keiki.checkInversionAmbiguity = False} - "counter-inversion-ambiguous" - inversionAmbiguousEventStreamDef of - Right validated -> validated - Left warnings -> error ("expected inversion-ambiguity override to validate: " <> show warnings) - -inversionAmbiguousTransducer :: SymTransducer (HsPred '[] CounterCommand) '[] CounterState CounterCommand CounterEvent -inversionAmbiguousTransducer = - counterTransducer - { edgesOut = \case - Counting -> - [ ambiguousEdge - , ambiguousEdge - ] - } - where - ambiguousEdge = - Edge - { guard = PAnd (matchInCtor addCtor) (PNot PBot) - , update = UKeep - , output = [pack addCtor counterAddedCtor (inpCtor addCtor #amount *: oNil)] - , target = Counting - , mode = Keiki.Live - } - -{- | This edge reads @Add.amount@ while guarded only by @PTop@. A different -command constructor would reach the partial projection and crash instead of -being rejected. --} -unguardedInputReadEventStreamDef :: CounterEventStream -unguardedInputReadEventStreamDef = - counterEventStreamDef & #transducer .~ unguardedInputReadTransducer - -unguardedInputReadTransducer :: SymTransducer (HsPred '[] CounterCommand) '[] CounterState CounterCommand CounterEvent -unguardedInputReadTransducer = - counterTransducer - { edgesOut = \case - Counting -> - [ Edge - { guard = PTop - , update = UKeep - , output = [pack addCtor counterAddedCtor (inpCtor addCtor #amount *: oNil)] - , target = Counting - , mode = Keiki.Live - } - ] - } - -{- | A silent self-loop that writes a register. With no emitted event the -write cannot be reconstructed from the durable log. --} -stateChangingEpsilonEventStreamDef :: SnapshotCounterEventStream -stateChangingEpsilonEventStreamDef = - snapshotCounterEventStreamDef & #transducer .~ stateChangingEpsilonTransducer - -stateChangingEpsilonTransducer :: SymTransducer (HsPred SnapshotCounterRegs CounterCommand) SnapshotCounterRegs CounterState CounterCommand CounterEvent -stateChangingEpsilonTransducer = - snapshotCounterTransducer - { edgesOut = \case - Counting -> - [ Edge - { guard = matchInCtor addCtor - , update = - USet - (#lastAmount :: IndexN "lastAmount" SnapshotCounterRegs Int) - (Keiki.lit 0) - , output = [] - , target = Counting - , mode = Keiki.Live - } - ] - } - -type SilentMoveEventStream = EventStream (HsPred '[] CounterCommand) '[] DrainState CounterCommand CounterEvent - -silentMoveEventStreamDef :: SilentMoveEventStream -silentMoveEventStreamDef = - EventStream - { transducer = silentMoveTransducer - , initialState = Draining - , initialRegisters = RNil - , eventCodec = counterCodec - , resolveStreamName = Stream.streamName - , snapshotPolicy = Never - , stateCodec = Nothing - } - -silentMoveTransducer :: SymTransducer (HsPred '[] CounterCommand) '[] DrainState CounterCommand CounterEvent -silentMoveTransducer = - SymTransducer - { edgesOut = \case - Draining -> - [ Edge - { guard = matchInCtor addCtor - , update = UKeep - , output = [] - , target = Drained - , mode = Keiki.Live - } - ] - Drained -> [] - , initial = Draining - , initialRegs = RNil - , isFinal = (== Drained) - } - -isStateChangingEpsilon :: Keiki.TransducerValidationWarning s -> Bool -isStateChangingEpsilon = \case - Keiki.StateChangingEpsilon{} -> True - _ -> False - -expectValidationWarning :: - (Bounded s, Enum s, Ord s, Show s) => - Text -> - Text -> - EventStream (HsPred rs ci) rs s ci co -> - Expectation -expectValidationWarning label prefix eventStream = - case mkEventStream label eventStream of - Left warnings -> do - map eswStreamLabel warnings `shouldSatisfy` all (== label) - map eswReason warnings `shouldSatisfy` any (Text.isInfixOf prefix) - Right _ -> - expectationFailure - ( "expected mkEventStream to reject " - <> Text.unpack label - <> " with warning prefix " - <> Text.unpack prefix - ) - -type AddFields = '[ '("amount", Int)] - -type SkipEventStream = EventStream (HsPred '[] SkipCommand) '[] CounterState SkipCommand CounterEvent - -type ValidatedSkipEventStream = ValidatedEventStream (HsPred '[] SkipCommand) '[] CounterState SkipCommand CounterEvent - -skipEventStream :: ValidatedSkipEventStream -skipEventStream = mkEventStreamOrThrow "skip-command" skipEventStreamDef - -skipEventStreamDef :: SkipEventStream -skipEventStreamDef = - EventStream - { transducer = skipTransducer - , initialState = Counting - , initialRegisters = RNil - , eventCodec = counterCodec - , resolveStreamName = Stream.streamName - , snapshotPolicy = Never - , stateCodec = Nothing - } - -skipTransducer :: SymTransducer (HsPred '[] SkipCommand) '[] CounterState SkipCommand CounterEvent -skipTransducer = - SymTransducer - { edgesOut = \case - Counting -> - [ Edge - { guard = matchInCtor sAddCtor - , update = UKeep - , output = [pack sAddCtor counterAddedCtor (inpCtor sAddCtor #amount *: oNil)] - , target = Counting - , mode = Keiki.Live - } - , Edge - { guard = matchInCtor sSkipCtor - , update = UKeep - , output = [] - , target = Counting - , mode = Keiki.Live - } - ] - , initial = Counting - , initialRegs = RNil - , isFinal = \_ -> False - } - -sAddCtor :: InCtor SkipCommand AddFields -sAddCtor = - InCtor - { icName = "SAdd" - , icMatch = \case - SAdd amount -> Just (RCons Proxy amount RNil) - SSkip -> Nothing - , icBuild = \case - RCons _ amount RNil -> SAdd amount - } - -sSkipCtor :: InCtor SkipCommand '[] -sSkipCtor = - InCtor - { icName = "SSkip" - , icMatch = \case - SAdd{} -> Nothing - SSkip -> Just RNil - , icBuild = \case - RNil -> SSkip - } - -addCtor :: InCtor CounterCommand AddFields -addCtor = - InCtor - { icName = "Add" - , icMatch = \case - Add amount -> Just (RCons Proxy amount RNil) - , icBuild = \case - RCons _ amount RNil -> Add amount - } - -counterAddedCtor :: WireCtor CounterEvent (Int, ()) -counterAddedCtor = - WireCtor - { wcName = "CounterAdded" - , wcMatch = \case - CounterAdded amount -> Just (amount, ()) - CounterAudited{} -> Nothing - , wcBuild = \case - (amount, ()) -> CounterAdded amount - } - -counterAuditedCtor :: WireCtor CounterEvent (Int, ()) -counterAuditedCtor = - WireCtor - { wcName = "CounterAudited" - , wcMatch = \case - CounterAudited amount -> Just (amount, ()) - CounterAdded{} -> Nothing - , wcBuild = \case - (amount, ()) -> CounterAudited amount - } - -counterCodec :: Codec CounterEvent -counterCodec = - Codec - { eventTypes = EventType "CounterAdded" :| [EventType "CounterAudited"] - , eventType = \case - CounterAdded{} -> EventType "CounterAdded" - CounterAudited{} -> EventType "CounterAudited" - , schemaVersion = 1 - , encode = \case - CounterAdded amount -> object ["amount" Aeson..= amount] - CounterAudited amount -> object ["amount" Aeson..= amount, "audited" Aeson..= True] - , decode = parseCounterEvent - , upcasters = [] - } - -parseCounterEvent :: EventType -> Value -> Either Text CounterEvent -parseCounterEvent (EventType tag) value = - case parseEither parser value of - Right event -> Right event - Left message -> Left (fromStringLiteral message) - where - parser = withObject "CounterEvent" $ \objectValue -> do - amount <- objectValue .: "amount" - case tag of - "CounterAdded" -> pure (CounterAdded amount) - "CounterAudited" -> pure (CounterAudited amount) - _ -> fail "unknown counter event type" - --- * Divert fixture (plan 143: replay-only transitions / black-acuity) ----- - -type DivertEventStream = EventStream (HsPred '[] DivertCommand) '[] DivertState DivertCommand DivertEvent - -type ValidatedDivertEventStream = ValidatedEventStream (HsPred '[] DivertCommand) '[] DivertState DivertCommand DivertEvent - -data DivertCommand - = ConfirmDivert !Bool - deriving stock (Generic, Eq, Show) - -newtype DivertEvent - = DivertConfirmed Bool - deriving stock (Generic, Eq, Show) - -data DivertState - = DivertHeld - deriving stock (Generic, Eq, Show, Enum, Bounded, Ord) - -type DivertFields = '[ '("acuityBlack", Bool)] - -confirmDivertCtor :: InCtor DivertCommand DivertFields -confirmDivertCtor = - InCtor - { icName = "ConfirmDivert" - , icMatch = \case - ConfirmDivert acuityBlack -> Just (RCons Proxy acuityBlack RNil) - , icBuild = \case - RCons _ acuityBlack RNil -> ConfirmDivert acuityBlack - } - -divertConfirmedCtor :: WireCtor DivertEvent (Bool, ()) -divertConfirmedCtor = - WireCtor - { wcName = "DivertConfirmed" - , wcMatch = \case - DivertConfirmed acuityBlack -> Just (acuityBlack, ()) - , wcBuild = \case - (acuityBlack, ()) -> DivertConfirmed acuityBlack - } - -divertCodec :: Codec DivertEvent -divertCodec = - Codec - { eventTypes = EventType "DivertConfirmed" :| [] - , eventType = \_ -> EventType "DivertConfirmed" - , schemaVersion = 1 - , encode = \case - DivertConfirmed acuityBlack -> object ["acuityBlack" Aeson..= acuityBlack] - , decode = parseDivertEvent - , upcasters = [] - } - -parseDivertEvent :: EventType -> Value -> Either Text DivertEvent -parseDivertEvent _ value = - case parseEither parser value of - Right event -> Right event - Left message -> Left (fromStringLiteral message) - where - parser = withObject "DivertConfirmed" $ \objectValue -> - DivertConfirmed <$> objectValue .: "acuityBlack" - --- | The old rule: confirm any reservation. -divertOldGuard :: HsPred '[] DivertCommand -divertOldGuard = matchInCtor confirmDivertCtor - --- | The tightened rule: confirm only non-black acuity. -divertNewGuard :: HsPred '[] DivertCommand -divertNewGuard = - PAnd - (matchInCtor confirmDivertCtor) - (inpCtor confirmDivertCtor #acuityBlack .== Keiki.lit False) - --- | The removed region, @old ∧ ¬new@: exactly black acuity. -divertRemovedRegionGuard :: HsPred '[] DivertCommand -divertRemovedRegionGuard = - PAnd - (matchInCtor confirmDivertCtor) - (inpCtor confirmDivertCtor #acuityBlack .== Keiki.lit True) - -divertConfirmEdge :: - HsPred '[] DivertCommand -> - Keiki.EdgeMode -> - Edge (HsPred '[] DivertCommand) '[] DivertCommand DivertEvent DivertState -divertConfirmEdge edgeGuard edgeMode = - Edge - { guard = edgeGuard - , update = UKeep - , output = [pack confirmDivertCtor divertConfirmedCtor (inpCtor confirmDivertCtor #acuityBlack *: oNil)] - , target = DivertHeld - , mode = edgeMode - } - -divertEventStreamDef :: - [Edge (HsPred '[] DivertCommand) '[] DivertCommand DivertEvent DivertState] -> - DivertEventStream -divertEventStreamDef heldEdges = - EventStream - { transducer = - SymTransducer - { edgesOut = \case - DivertHeld -> heldEdges - , initial = DivertHeld - , initialRegs = RNil - , isFinal = const False - } - , initialState = DivertHeld - , initialRegisters = RNil - , eventCodec = divertCodec - , resolveStreamName = Stream.streamName - , snapshotPolicy = Never - , stateCodec = Nothing - } - --- | Machine A: the original permissive rule. -permissiveDivertEventStream :: ValidatedDivertEventStream -permissiveDivertEventStream = - mkEventStreamOrThrow - "divert-permissive" - (divertEventStreamDef [divertConfirmEdge divertOldGuard Keiki.Live]) - --- | Machine B without the twin: the tightened rule alone. -tightenedDivertEventStream :: ValidatedDivertEventStream -tightenedDivertEventStream = - mkEventStreamOrThrow - "divert-tightened" - (divertEventStreamDef [divertConfirmEdge divertNewGuard Keiki.Live]) - -{- | Machine B with the replay-only twin carrying the removed region: -the tightened rule governs new traffic; black-acuity history keeps -its inverting edge. --} -twinDivertEventStream :: ValidatedDivertEventStream -twinDivertEventStream = - mkEventStreamOrThrow - "divert-twin" - ( divertEventStreamDef - [ divertConfirmEdge divertNewGuard Keiki.Live - , divertConfirmEdge divertRemovedRegionGuard Keiki.ReplayOnly - ] - ) - -counterProcessManager :: - ProcessManager - CounterEvent - (HsPred '[] CounterCommand) - '[] - CounterState - CounterCommand - CounterEvent - (HsPred '[] CounterCommand) - '[] - CounterState - CounterCommand - CounterEvent -counterProcessManager = - ProcessManager - { name = "counter-pm" - , correlate = \_ -> "order-1" - , eventStream = counterEventStream - , streamFor = \correlationId -> stream ("pm:counter-" <> correlationId) - , targetEventStream = counterEventStream - , targetProjections = const [] - , handle = \case - CounterAdded amount -> - ProcessManagerAction - { command = Add amount - , commands = - [ PMCommand - { target = stream "counter-target-order-1" - , command = Add amount - } - ] - , timers = [counterTimerRequest] - } - CounterAudited amount -> - ProcessManagerAction - { command = Add amount - , commands = [] - , timers = [] - } - } - -timerOnlyProcessManager :: - ProcessManager - CounterEvent - (HsPred '[] CounterCommand) - '[] - CounterState - CounterCommand - CounterEvent - (HsPred '[] CounterCommand) - '[] - CounterState - CounterCommand - CounterEvent -timerOnlyProcessManager = - ProcessManager - { name = "timer-only-pm" - , correlate = \_ -> "order-1" - , eventStream = noOpCounterEventStream - , streamFor = \correlationId -> stream ("pm:timer-only-" <> correlationId) - , targetEventStream = counterEventStream - , targetProjections = const [] - , handle = \case - CounterAdded amount -> - ProcessManagerAction - { command = Add amount - , commands = [] - , timers = - [ counterTimerRequest - & #processManagerName - .~ "timer-only-pm" - ] - } - CounterAudited amount -> - ProcessManagerAction - { command = Add amount - , commands = [] - , timers = [] - } - } - --- A process manager whose OWN state stream snapshots under Every 2. --- This is the first PM fixture to exercise a state-stream snapshot: the only --- difference from counterProcessManager is that its eventStream carries a --- snapshotPolicy + stateCodec (it reuses snapshotCounterEventStream), so --- runProcessManagerOnce's manager-state append (which goes through --- runCommandWithSql) writes and reuses snapshots. The manager registers are --- SnapshotCounterRegs because the eventStream is a SnapshotCounterEventStream; --- the target side stays '[]/counterEventStream exactly as counterProcessManager. -pmSnapshotCounterEventStreamDef :: SnapshotCounterEventStream -pmSnapshotCounterEventStreamDef = snapshotCounterEventStreamDef - -pmSnapshotCounterEventStream :: ValidatedSnapshotCounterEventStream -pmSnapshotCounterEventStream = mkEventStreamOrThrow "pm-snapshot-counter" pmSnapshotCounterEventStreamDef - -pmSnapshotProcessManager :: - ProcessManager - CounterEvent - (HsPred SnapshotCounterRegs CounterCommand) - SnapshotCounterRegs - CounterState - CounterCommand - CounterEvent - (HsPred '[] CounterCommand) - '[] - CounterState - CounterCommand - CounterEvent -pmSnapshotProcessManager = - ProcessManager - { name = "counter-snap-pm" - , correlate = \_ -> "order-1" - , eventStream = pmSnapshotCounterEventStream - , streamFor = \correlationId -> stream ("pm:counter-snap-" <> correlationId) - , targetEventStream = counterEventStream - , targetProjections = const [] - , handle = \case - CounterAdded amount -> - ProcessManagerAction - { command = Add amount - , commands = [] -- keep the test focused on the manager state stream - , timers = [] - } - CounterAudited amount -> - ProcessManagerAction - { command = Add amount - , commands = [] - , timers = [] - } - } - -workflowProcessManager :: - Text -> - Text -> - Text -> - ProcessManager - CounterEvent - (HsPred '[] CounterCommand) - '[] - CounterState - CounterCommand - CounterEvent - (HsPred '[] CounterCommand) - '[] - CounterState - CounterCommand - CounterEvent -workflowProcessManager managerName managerCategory targetStreamName = - counterProcessManager - { name = managerName - , streamFor = \correlationId -> stream (managerCategory <> "-" <> correlationId) - , handle = \case - CounterAdded amount -> - ProcessManagerAction - { command = Add amount - , commands = - [ PMCommand - { target = stream targetStreamName - , command = Add amount - } - ] - , timers = [] - } - CounterAudited amount -> - ProcessManagerAction - { command = Add amount - , commands = [] - , timers = [] - } - } - -assertWorkflowProcessManagerAppended :: - Either - Store.StoreError - ( Either - CommandError - (ProcessManagerResult CounterEventStream CounterEventStream) - ) -> - Expectation -assertWorkflowProcessManagerAppended = \case - Right (Right pmResult) -> do - pmResult ^. #managerResult `shouldSatisfy` \case - PMStateAppended{} -> True - _ -> False - pmResult ^. #commandResults `shouldSatisfy` \case - [PMCommandAppended{}] -> True - _ -> False - other -> expectationFailure ("expected workflow process-manager success, got " <> show other) - -counterTimerRequest :: TimerRequest -counterTimerRequest = - TimerRequest - { timerId = TimerId sampleUuid - , processManagerName = "counter-pm" - , correlationId = "order-1" - , fireAt = dueTimerTime - , payload = object ["kind" Aeson..= ("counter-timeout" :: Text)] - } - -dueTimerTime :: UTCTime -dueTimerTime = UTCTime (ModifiedJulianDay 1) (secondsToDiffTime 0) - -timerStatusAndErrorStmt :: Statement UUID (Maybe (Text, Maybe Text)) -timerStatusAndErrorStmt = - preparable - """ - SELECT status, last_error - FROM keiro.keiro_timers - WHERE timer_id = $1 - """ - (E.param (E.nonNullable E.uuid)) - (D.rowMaybe ((,) <$> D.column (D.nonNullable D.text) <*> D.column (D.nullable D.text))) - --- | Read a timer's status and JSON payload by id (for the workflow-sleep tests). -sleepTimerStatusStmt :: Statement UUID (Maybe (Text, Value)) -sleepTimerStatusStmt = - preparable - """ - SELECT status, payload - FROM keiro.keiro_timers - WHERE timer_id = $1 - """ - (E.param (E.nonNullable E.uuid)) - (D.rowMaybe ((,) <$> D.column (D.nonNullable D.text) <*> D.column (D.nonNullable D.jsonb))) - --- | Read a timer's fire time by id (for workflow-sleep re-arm tests). -sleepTimerFireAtStmt :: Statement UUID (Maybe UTCTime) -sleepTimerFireAtStmt = - preparable - """ - SELECT fire_at - FROM keiro.keiro_timers - WHERE timer_id = $1 - """ - (E.param (E.nonNullable E.uuid)) - (D.rowMaybe (D.column (D.nonNullable D.timestamptz))) - -recordedFrom :: EventData -> RecordedEvent -recordedFrom event = - RecordedEvent - { eventId = EventId sampleUuid - , eventType = event ^. #eventType - , streamVersion = StreamVersion 1 - , globalPosition = GlobalPosition 1 - , originalStreamId = StreamId 1 - , originalVersion = StreamVersion 1 - , payload = event ^. #payload - , metadata = event ^. #metadata - , causationId = Nothing - , correlationId = Nothing - , createdAt = UTCTime (ModifiedJulianDay 0) (secondsToDiffTime 0) - } - -recordedFromEventId :: EventId -> CounterEvent -> RecordedEvent -recordedFromEventId eventId event = - case encodeForAppend counterCodec event of - Right encoded -> recordedFrom encoded & #eventId .~ eventId - Left err -> error ("test fixture failed to encode counter event: " <> show err) - -appendCounterEventWithId :: Store.KirokuStore -> StreamName -> EventId -> CounterEvent -> IO () -appendCounterEventWithId storeHandle streamName eventId event = do - encoded <- shouldBeRight (encodeForAppend counterCodec event) - outcome <- - Store.runStoreIO storeHandle $ - Store.appendToStream streamName NoStream [encoded & #eventId ?~ eventId] - case outcome of - Right _ -> pure () - Left err -> expectationFailure ("failed to insert concurrent duplicate event: " <> show err) - -appendCounterEvents :: Store.KirokuStore -> StreamName -> [CounterEvent] -> IO () -appendCounterEvents storeHandle destinationStreamName events = do - encoded <- traverse (shouldBeRight . encodeForAppend counterCodec) events - outcome <- - Store.runStoreIO storeHandle $ - Store.appendToStream destinationStreamName NoStream encoded - case outcome of - Right _ -> pure () - Left err -> expectationFailure ("failed to insert counter events: " <> show err) - --- Insert a real source event and drive Kiroku's acknowledgement bridge to park --- it in kiroku.dead_letters. A second event lets the test observe that the --- checkpoint advanced after the dead letter before stopping the subscription. -deadLetterCounterSource :: Store.KirokuStore -> SubscriptionName -> CounterEvent -> IO RecordedEvent -deadLetterCounterSource storeHandle subName sourceEvent = do - appendCounterEvents - storeHandle - (StreamName "counter-replay-source") - [sourceEvent, CounterAdded 0] - let subConfig = - ( KirokuSub.defaultSubscriptionConfig - subName - AllStreams - (\_ -> pure KirokuSub.Continue) - ) - { KirokuSub.retryPolicy = KirokuSub.RetryPolicy 1 - } - pull label source = do - result <- timeout 5_000_000 (Streamly.uncons source) - case result of - Just (Just itemAndRest) -> pure itemAndRest - Just Nothing -> fail (label <> ": subscription ended early") - Nothing -> fail (label <> ": timed out waiting for delivery") - (stream0, cancelStream) <- subscriptionAckStream storeHandle subConfig 4 - ( do - (first, stream1) <- pull "source delivery" stream0 - atomically $ - putTMVar - (ackReply first) - (KirokuSub.Retry (KirokuSub.RetryDelay 0)) - (next, stream2) <- pull "event after source dead letter" stream1 - ackEvent next ^. #eventId `shouldNotBe` ackEvent first ^. #eventId - atomically (putTMVar (ackReply next) KirokuSub.Stop) - ended <- timeout 5_000_000 (Streamly.uncons stream2) - case ended of - Just Nothing -> pure () - Just (Just _) -> expectationFailure "replay fixture delivered after Stop" - Nothing -> expectationFailure "replay fixture did not stop" - pure (ackEvent first) - ) - `finally` cancelStream - -classifyProcessManagerReplay :: ProcessManagerResult managerTarget commandTarget -> ReplayResult -classifyProcessManagerReplay result = - case result ^. #managerResult of - PMStateDuplicate{} - | Prelude.all commandIsDuplicate (result ^. #commandResults) -> ReplayedDuplicate - _ -> ReplayedFresh - where - commandIsDuplicate = \case - PMCommandDuplicate{} -> True - _ -> False - -processManagerReplayCounts :: Store.KirokuStore -> IO (Int, Int) -processManagerReplayCounts storeHandle = do - Right managerEvents <- - Store.runStoreIO storeHandle $ - Store.readStreamForward (StreamName "pm:counter-order-1") (StreamVersion 0) 10 - Right targetEvents <- - Store.runStoreIO storeHandle $ - Store.readStreamForward (StreamName "counter-target-order-1") (StreamVersion 0) 10 - pure (Vector.length managerEvents, Vector.length targetEvents) - -sampleUuid :: UUID -sampleUuid = - case fromString "018f0f18-17aa-7000-8000-000000000001" of - Just uuid -> uuid - Nothing -> error "invalid test UUID" - -sampleUuid2 :: UUID -sampleUuid2 = - case fromString "018f0f18-17aa-7000-8000-000000000002" of - Just uuid -> uuid - Nothing -> error "invalid test UUID" - -sampleUuid3 :: UUID -sampleUuid3 = - case fromString "018f0f18-17aa-7000-8000-000000000003" of - Just uuid -> uuid - Nothing -> error "invalid test UUID" - -shouldBeRight :: (HasCallStack, Show e) => Either e a -> IO a -shouldBeRight = \case - Right value -> pure value - Left err -> expectationFailure ("expected Right, got Left " <> show err) *> error "unreachable" - -shouldBeRight_ :: (HasCallStack, Show e) => Either e a -> Expectation -shouldBeRight_ = \case - Right _ -> pure () - Left err -> expectationFailure ("expected Right, got Left " <> show err) - -shouldBeLeft :: (HasCallStack, Eq e, Show e) => Either e a -> e -> Expectation -shouldBeLeft actual expected = - case actual of - Left err -> err `shouldBe` expected - Right _ -> expectationFailure ("expected Left " <> show expected <> ", got Right") - -fromStringLiteral :: String -> Text -fromStringLiteral = Text.pack - -snapshotVersionForStreamStmt :: Statement Text (Maybe StreamVersion) -snapshotVersionForStreamStmt = - preparable - """ - SELECT ks.stream_version - FROM keiro.keiro_snapshots ks - JOIN streams s ON s.stream_id = ks.stream_id - WHERE s.stream_name = $1 - """ - (E.param (E.nonNullable E.text)) - (D.rowMaybe (StreamVersion <$> D.column (D.nonNullable D.int8))) - -snapshotStateShapeForStreamStmt :: Statement Text (Maybe Text) -snapshotStateShapeForStreamStmt = - preparable - """ - SELECT ks.state_shape_hash - FROM keiro.keiro_snapshots ks - JOIN streams s ON s.stream_id = ks.stream_id - WHERE s.stream_name = $1 - """ - (E.param (E.nonNullable E.text)) - (D.rowMaybe (D.column (D.nonNullable D.text))) - -corruptSnapshotStateStmt :: Statement (Text, Value) () -corruptSnapshotStateStmt = - preparable - """ - UPDATE keiro.keiro_snapshots ks - SET state = $2 - FROM streams s - WHERE s.stream_id = ks.stream_id - AND s.stream_name = $1 - """ - ( contrazip2 - (E.param (E.nonNullable E.text)) - (E.param (E.nonNullable E.jsonb)) - ) - D.noResult - -corruptSnapshotShapeStmt :: Statement (Text, Text) () -corruptSnapshotShapeStmt = - preparable - """ - UPDATE keiro.keiro_snapshots ks - SET regfile_shape_hash = $2 - FROM streams s - WHERE s.stream_id = ks.stream_id - AND s.stream_name = $1 - """ - ( contrazip2 - (E.param (E.nonNullable E.text)) - (E.param (E.nonNullable E.text)) - ) - D.noResult - -counterReadModel :: ReadModel Text Int -counterReadModel = - ReadModel - { name = "counter-read-model" - , tableName = "counter_read_model" - , schema = "kiroku" - , subscriptionName = "counter-read-model-sub" - , version = 1 - , shapeHash = "counter-read-model-v1" - , defaultConsistency = Eventual - , strongScope = EntireLog - , query = \modelId -> Tx.statement modelId selectCounterReadModelStmt - } - -counterCategoryReadModel :: ReadModel Text Int -counterCategoryReadModel = - counterReadModel & #strongScope .~ CategoryHead "counter" - -registerReadModelDefinition :: (Store :> es) => ReadModel q r -> Eff es () -registerReadModelDefinition readModel = - void $ - registerReadModel - (readModel ^. #name) - (readModel ^. #version) - (readModel ^. #shapeHash) - -initializeRegisteredReadModel :: - (Store :> es) => - ReadModel q r -> - Tx.Transaction () -> - Eff es () -initializeRegisteredReadModel readModel initializeTable = do - Store.runTransaction initializeTable - registerReadModelDefinition readModel - -counterInlineProjection :: InlineProjection CounterEvent -counterInlineProjection = - InlineProjection - { name = "counter-inline-projection" - , apply = \event recorded -> - case event of - CounterAdded amount -> - Tx.statement - ( "inline" - , Prelude.fromIntegral amount - , globalPositionToInt (recorded ^. #globalPosition) - , Just (eventIdToUuid (recorded ^. #eventId)) - , metadataActor recorded - ) - upsertCounterReadModelStmt - CounterAudited{} -> pure () - } - -counterAsyncProjection :: AsyncProjection -counterAsyncProjection = - AsyncProjection - { name = "counter-async-projection" - , readModelName = "counter-read-model" - , subscriptionName = "counter-read-model-sub" - , applyRecorded = \recorded -> - case decodeRecorded counterCodec recorded of - Right (CounterAdded amount) -> - Tx.statement - ( "async-idempotent" - , Prelude.fromIntegral amount - , globalPositionToInt (recorded ^. #globalPosition) - , Just (eventIdToUuid (recorded ^. #eventId)) - , Nothing - ) - upsertCounterReadModelStmt - Right CounterAudited{} -> pure () - Left _ -> pure () - , idempotencyKey = \recorded -> recorded ^. #eventId - } - -fastWaitOptions :: PositionWaitOptions -fastWaitOptions = - PositionWaitOptions - { target = Nothing - , timeoutMicros = 50000 - , pollMicros = 5000 - } - -initializeCounterReadModelTable :: Tx.Transaction () -initializeCounterReadModelTable = - Tx.sql - """ - CREATE TABLE IF NOT EXISTS counter_read_model ( - model_id TEXT PRIMARY KEY, - amount BIGINT NOT NULL, - last_seen BIGINT NOT NULL, - source_event_id UUID UNIQUE, - actor TEXT - ) - """ - --- A read model whose data table lives in an application-configured schema --- (@app_reads@), demonstrating EP-4's configurable projection schema. Its SQL is --- fully qualified via 'placedTable'; Keiro's own metadata stays in @keiro@. -placedTable :: Text -placedTable = qualifyTable "app_reads" "placed_counter" - -placedReadModel :: ReadModel Text Int -placedReadModel = - ReadModel - { name = "placed-counter-read-model" - , tableName = "placed_counter" - , schema = "app_reads" - , subscriptionName = "placed-counter-sub" - , version = 1 - , shapeHash = "placed-counter-v1" - , defaultConsistency = Eventual - , strongScope = EntireLog - , query = \modelId -> Tx.statement modelId selectPlacedStmt - } - -placedInlineProjection :: InlineProjection CounterEvent -placedInlineProjection = - InlineProjection - { name = "placed-inline-projection" - , apply = \event recorded -> - case event of - CounterAdded amount -> - Tx.statement - ( "placed" - , Prelude.fromIntegral amount - , globalPositionToInt (recorded ^. #globalPosition) - ) - upsertPlacedStmt - CounterAudited{} -> pure () - } - -initializePlacedTable :: Tx.Transaction () -initializePlacedTable = - Tx.sql $ - TE.encodeUtf8 $ - "CREATE TABLE IF NOT EXISTS " - <> placedTable - <> " (\n" - <> " model_id TEXT PRIMARY KEY,\n" - <> " amount BIGINT NOT NULL,\n" - <> " last_seen BIGINT NOT NULL\n" - <> ")" - -upsertPlacedStmt :: Statement (Text, Int64, Int64) () -upsertPlacedStmt = - preparable - ( "INSERT INTO " - <> placedTable - <> " (model_id, amount, last_seen)\n" - <> "VALUES ($1, $2, $3)\n" - <> "ON CONFLICT (model_id) DO UPDATE\n" - <> " SET amount = EXCLUDED.amount, last_seen = EXCLUDED.last_seen" - ) - ( contrazip3 - (E.param (E.nonNullable E.text)) - (E.param (E.nonNullable E.int8)) - (E.param (E.nonNullable E.int8)) - ) - D.noResult - -selectPlacedStmt :: Statement Text Int -selectPlacedStmt = - preparable - ("SELECT COALESCE((SELECT amount FROM " <> placedTable <> " WHERE model_id = $1), 0)") - (E.param (E.nonNullable E.text)) - (D.singleRow (Prelude.fromIntegral <$> D.column (D.nonNullable D.int8))) - --- Count matching base tables in a given schema; proves table placement. -pgTableCountStmt :: Statement (Text, Text) Int -pgTableCountStmt = - preparable - "SELECT count(*)::int FROM pg_tables WHERE schemaname = $1 AND tablename = $2" - ( contrazip2 - (E.param (E.nonNullable E.text)) - (E.param (E.nonNullable E.text)) - ) - (D.singleRow (Prelude.fromIntegral <$> D.column (D.nonNullable D.int4))) - -initializeProjectionDedupCounterTable :: Tx.Transaction () -initializeProjectionDedupCounterTable = - Tx.sql - """ - CREATE TABLE IF NOT EXISTS projection_dedup_counter ( - id BOOLEAN PRIMARY KEY DEFAULT TRUE, - amount BIGINT NOT NULL - ); - - INSERT INTO projection_dedup_counter (id, amount) - VALUES (TRUE, 0) - ON CONFLICT (id) DO NOTHING; - """ - -upsertCounterReadModelStmt :: Statement (Text, Int64, Int64, Maybe UUID, Maybe Text) () -upsertCounterReadModelStmt = - preparable - """ - INSERT INTO counter_read_model (model_id, amount, last_seen, source_event_id, actor) - VALUES ($1, $2, $3, $4, $5) - ON CONFLICT (source_event_id) DO NOTHING - """ - ( contrazip5 - (E.param (E.nonNullable E.text)) - (E.param (E.nonNullable E.int8)) - (E.param (E.nonNullable E.int8)) - (E.param (E.nullable E.uuid)) - (E.param (E.nullable E.text)) - ) - D.noResult - -incrementProjectionDedupCounterStmt :: Statement () () -incrementProjectionDedupCounterStmt = - preparable - """ - UPDATE projection_dedup_counter - SET amount = amount + 1 - WHERE id = TRUE - """ - E.noParams - D.noResult - -selectProjectionDedupCounterStmt :: Statement () Int -selectProjectionDedupCounterStmt = - preparable - """ - SELECT amount - FROM projection_dedup_counter - WHERE id = TRUE - """ - E.noParams - (D.singleRow (Prelude.fromIntegral <$> D.column (D.nonNullable D.int8))) - -projectionDedupCountStmt :: Statement Text Int64 -projectionDedupCountStmt = - preparable - """ - SELECT count(*) - FROM keiro.keiro_projection_dedup - WHERE projection_name = $1 - """ - (E.param (E.nonNullable E.text)) - (D.singleRow (D.column (D.nonNullable D.int8))) - -selectCounterMetaStmt :: Statement Text (Int64, Maybe Text, Maybe UUID) -selectCounterMetaStmt = - preparable - """ - SELECT amount, actor, source_event_id - FROM counter_read_model - WHERE model_id = $1 - """ - (E.param (E.nonNullable E.text)) - ( D.singleRow - ( (,,) - <$> D.column (D.nonNullable D.int8) - <*> D.column (D.nullable D.text) - <*> D.column (D.nullable D.uuid) - ) - ) - -selectCounterReadModelStmt :: Statement Text Int -selectCounterReadModelStmt = - preparable - """ - SELECT COALESCE((SELECT amount FROM counter_read_model WHERE model_id = $1), 0) - """ - (E.param (E.nonNullable E.text)) - (D.singleRow (Prelude.fromIntegral <$> D.column (D.nonNullable D.int8))) - -upsertSubscriptionCursorStmt :: Statement (Text, Int64) () -upsertSubscriptionCursorStmt = - preparable - """ - INSERT INTO subscriptions (subscription_name, stream_name, last_seen) - VALUES ($1, '$all', $2) - ON CONFLICT (subscription_name, consumer_group_member) DO UPDATE - SET last_seen = EXCLUDED.last_seen, - updated_at = now() - """ - ( contrazip2 - (E.param (E.nonNullable E.text)) - (E.param (E.nonNullable E.int8)) - ) - D.noResult - -upsertSubscriptionCursorMemberStmt :: Statement (Text, Int32, Int64) () -upsertSubscriptionCursorMemberStmt = - preparable - """ - INSERT INTO subscriptions (subscription_name, stream_name, consumer_group_member, consumer_group_size, last_seen) - VALUES ($1, '$all', $2, 2, $3) - ON CONFLICT (subscription_name, consumer_group_member) DO UPDATE - SET last_seen = EXCLUDED.last_seen, - updated_at = now() - """ - ( contrazip3 - (E.param (E.nonNullable E.text)) - (E.param (E.nonNullable E.int4)) - (E.param (E.nonNullable E.int8)) - ) - D.noResult - -updateReadModelVersionStmt :: Statement (Text, Int64) () -updateReadModelVersionStmt = - preparable - """ - UPDATE keiro.keiro_read_models - SET version = $2 - WHERE name = $1 - """ - ( contrazip2 - (E.param (E.nonNullable E.text)) - (E.param (E.nonNullable E.int8)) - ) - D.noResult - -updateReadModelStatusStmt :: Statement (Text, Text) () -updateReadModelStatusStmt = - preparable - """ - UPDATE keiro.keiro_read_models - SET status = $2 - WHERE name = $1 - """ - ( contrazip2 - (E.param (E.nonNullable E.text)) - (E.param (E.nonNullable E.text)) - ) - D.noResult - -readModelXminStmt :: Statement Text Text -readModelXminStmt = - preparable - """ - SELECT xmin::text - FROM keiro.keiro_read_models - WHERE name = $1 - """ - (E.param (E.nonNullable E.text)) - (D.singleRow (D.column (D.nonNullable D.text))) - -globalPositionToInt :: GlobalPosition -> Int64 -globalPositionToInt (GlobalPosition value) = value - -eventIdToUuid :: EventId -> UUID -eventIdToUuid (EventId value) = value - -metadataActor :: RecordedEvent -> Maybe Text -metadataActor recorded = do - Aeson.Object o <- recorded ^. #metadata - Aeson.String s <- KeyMap.lookup "actor" o - pure s - --- Router test fixtures: an effectful, data-dependent fan-out whose target set --- is stored in a read-model table (router_targets) rather than computed purely. - -newtype RouteGroup = RouteGroup Text - deriving stock (Generic, Eq, Show) - -{- | Maps a routing group to the list of target counter stream identifiers seeded -for it. The query is genuinely effectful: 'demoRouter' calls it via 'runQuery'. --} -routerTargetsReadModel :: ReadModel Text [Text] -routerTargetsReadModel = - ReadModel - { name = "router-targets-read-model" - , tableName = "router_targets" - , schema = "kiroku" - , subscriptionName = "router-targets-sub" - , version = 1 - , shapeHash = "router-targets-v1" - , defaultConsistency = Eventual - , strongScope = EntireLog - , query = \groupId -> Tx.statement groupId selectRouterTargetsStmt - } - -demoRouter :: - (IOE :> es, Store :> es) => - Router - RouteGroup - (HsPred '[] CounterCommand) - '[] - CounterState - CounterCommand - CounterEvent - es -demoRouter = - Router - { name = "demo-router" - , key = \(RouteGroup g) -> g - , resolve = \(RouteGroup g) -> do - result <- runQuery Nothing routerTargetsReadModel g - pure $ case result of - Right targetIds -> - [ PMCommand{target = stream targetId, command = Add 1} - | targetId <- targetIds - ] - Left _ -> [] - , targetEventStream = counterEventStream - , targetProjections = const [] - } - -unstableRouter :: - (IOE :> es) => - IORef Int -> - (Int -> [Text]) -> - Router - RouteGroup - (HsPred '[] CounterCommand) - '[] - CounterState - CounterCommand - CounterEvent - es -unstableRouter attemptsRef targetsFor = - Router - { name = "unstable-router" - , key = \(RouteGroup g) -> g - , resolve = \_ -> do - attempt <- liftIO (atomicModifyIORef' attemptsRef (\n -> (n + 1, n))) - pure - [ PMCommand{target = stream targetId, command = Add 1} - | targetId <- targetsFor attempt - ] - , targetEventStream = counterEventStream - , targetProjections = const [] - } - -isAppended :: PMCommandResult target -> Bool -isAppended = \case - PMCommandAppended{} -> True - _ -> False - -isDuplicate :: PMCommandResult target -> Bool -isDuplicate = \case - PMCommandDuplicate{} -> True - _ -> False - -initializeRouterTargetsTable :: Tx.Transaction () -initializeRouterTargetsTable = - Tx.sql - """ - CREATE TABLE IF NOT EXISTS router_targets ( - group_id TEXT NOT NULL, - target_id TEXT NOT NULL - ) - """ - -insertRouterTargetStmt :: Statement (Text, Text) () -insertRouterTargetStmt = - preparable - """ - INSERT INTO router_targets (group_id, target_id) - VALUES ($1, $2) - """ - ( contrazip2 - (E.param (E.nonNullable E.text)) - (E.param (E.nonNullable E.text)) - ) - D.noResult - -selectRouterTargetsStmt :: Statement Text [Text] -selectRouterTargetsStmt = - preparable - """ - SELECT target_id - FROM router_targets - WHERE group_id = $1 - ORDER BY target_id - """ - (E.param (E.nonNullable E.text)) - (D.rowList (D.column (D.nonNullable D.text))) - --- Router worker fixtures: an in-memory Shibuya adapter that records every --- finalized AckDecision, plus a router whose dispatch always fails. - -inMemoryAdapter :: - (IOE :> es) => - IORef [AckDecision] -> - [msg] -> - Adapter es msg -inMemoryAdapter decisionsRef messages = - Adapter - { adapterName = "router-test-adapter" - , source = Streamly.fromList (fmap ingest messages) - , shutdown = pure () - } - where - ingest message = - Ingested - { envelope = routerTestEnvelope message - , ack = AckHandle (\decision -> liftIO (modifyIORef' decisionsRef (<> [decision]))) - , lease = Nothing - } - -routerTestEnvelope :: msg -> Envelope msg -routerTestEnvelope message = - Envelope - { messageId = "router-test-message" - , cursor = Nothing - , partition = Nothing - , enqueuedAt = Nothing - , traceContext = Nothing - , headers = Nothing - , attempt = Nothing - , attributes = mempty - , payload = message - } - -{- | A target aggregate with no outgoing edges: every command is rejected -(CommandRejected), so a dispatch through it surfaces as PMCommandFailed, -driving the worker's AckHalt branch. --} -rejectingEventStreamDef :: CounterEventStream -rejectingEventStreamDef = - counterEventStreamDef & #transducer .~ rejectingTransducer - -rejectingEventStream :: ValidatedCounterEventStream -rejectingEventStream = mkEventStreamOrThrow "rejecting-counter" rejectingEventStreamDef - -{- | Accept every Add command except amount 9, which exercises a worker that -dead-letters one rejected dispatch and then successfully processes the next. --} -rejectNineEventStream :: ValidatedCounterEventStream -rejectNineEventStream = mkEventStreamOrThrow "reject-nine-counter" rejectNineEventStreamDef - -rejectNineEventStreamDef :: CounterEventStream -rejectNineEventStreamDef = - counterEventStreamDef & #transducer .~ rejectNineTransducer - -rejectNineTransducer :: SymTransducer (HsPred '[] CounterCommand) '[] CounterState CounterCommand CounterEvent -rejectNineTransducer = - SymTransducer - { edgesOut = \case - Counting -> - [ Edge - { guard = - PAnd - (matchInCtor addCtor) - (PNot (inpCtor addCtor #amount .== Keiki.lit 9)) - , update = UKeep - , output = [pack addCtor counterAddedCtor (inpCtor addCtor #amount *: oNil)] - , target = Counting - , mode = Keiki.Live - } - ] - , initial = Counting - , initialRegs = RNil - , isFinal = \_ -> False - } - -rejectingTransducer :: SymTransducer (HsPred '[] CounterCommand) '[] CounterState CounterCommand CounterEvent -rejectingTransducer = - SymTransducer - { edgesOut = \case - Counting -> [] - , initial = Counting - , initialRegs = RNil - , isFinal = \_ -> False - } - -failingRouter :: - Router - RouteGroup - (HsPred '[] CounterCommand) - '[] - CounterState - CounterCommand - CounterEvent - es -failingRouter = - Router - { name = "failing-router" - , key = \(RouteGroup g) -> g - , resolve = \_ -> pure [PMCommand{target = stream "failing-target", command = Add 1}] - , targetEventStream = rejectingEventStream - , targetProjections = const [] - } - --- Flatten exported counter/gauge points to (instrument name, value). -flattenScalarPoints :: [ResourceMetricsExport] -> [(Text, NumberValue)] -flattenScalarPoints rmes = - [ (name, val) - | rme <- rmes - , scope <- Vector.toList (resourceMetricsScopes rme) - , export <- Vector.toList (scopeMetricsExports scope) - , (name, val) <- pointsOf export - ] - where - pointsOf (MetricExportSum n _ _ _ _ _ _ pts) = - [(n, sumDataPointValue p) | p <- Vector.toList pts] - pointsOf (MetricExportGauge n _ _ _ _ pts) = - [(n, gaugeDataPointValue p) | p <- Vector.toList pts] - pointsOf _ = [] - --- Flatten exported histogram points to (instrument name, count, sum). -flattenHistogramPoints :: [ResourceMetricsExport] -> [(Text, Word64, Double)] -flattenHistogramPoints rmes = - [ (n, histogramDataPointCount p, histogramDataPointSum p) - | rme <- rmes - , scope <- Vector.toList (resourceMetricsScopes rme) - , export <- Vector.toList (scopeMetricsExports scope) - , MetricExportHistogram n _ _ _ _ pts <- [export] - , p <- Vector.toList pts - ] - --- =========================================================================== --- EP-51 sharded-subscription test helpers --- =========================================================================== - --- A test sink the sharded handlers write to: one row per processed event, --- idempotent on event_id (an at-least-once handler may redeliver during a --- rebalance). worker_tag identifies which worker process handled it; stream_id --- is the originating stream (the partition key kiroku hashes on). -createShardSinkSql :: ByteString -createShardSinkSql = - "CREATE TABLE IF NOT EXISTS shard_sink \ - \(event_id uuid PRIMARY KEY, worker_tag int NOT NULL, stream_id bigint NOT NULL)" - --- Seed @nStreams@ category-@orders@ streams with @perStream@ events each --- (upsert append, so it is safe to call twice in one test). Returns the total --- number of events appended. -seedOrders :: Store.KirokuStore -> Int -> Int -> IO Int -seedOrders store nStreams perStream = do - for_ [0 .. nStreams - 1] $ \i -> do - let sname = StreamName ("orders-" <> Text.pack (show i)) - evs = - [ EventData - { eventId = Nothing - , eventType = EventType "OrderPlaced" - , payload = object ["n" Aeson..= (j :: Int)] - , metadata = Nothing - , causationId = Nothing - , correlationId = Nothing - } - | j <- [0 .. perStream - 1] - ] - Right _ <- Store.runStoreIO store $ Store.appendToStream sname AnyVersion evs - pure () - pure (nStreams * perStream) - --- A handler for worker @tag@: idempotently record (event_id, tag, stream_id). -sinkHandler :: Store.KirokuStore -> Int32 -> RecordedEvent -> IO () -sinkHandler store tag ev = - void $ - Store.runStoreIO store $ - Store.runTransaction $ - Tx.statement (eventUuid (ev ^. #eventId), tag, streamIdInt (ev ^. #originalStreamId)) insertShardSinkStmt - where - eventUuid (EventId u) = u - streamIdInt (StreamId s) = s - -insertShardSinkStmt :: Statement (UUID, Int32, Int64) () -insertShardSinkStmt = - preparable - "INSERT INTO shard_sink (event_id, worker_tag, stream_id) VALUES ($1, $2, $3) ON CONFLICT (event_id) DO NOTHING" - ( contrazip3 - (E.param (E.nonNullable E.uuid)) - (E.param (E.nonNullable E.int4)) - (E.param (E.nonNullable E.int8)) - ) - D.noResult - -shardSinkCount :: Store.KirokuStore -> IO Int -shardSinkCount store = - either (const 0) id - <$> Store.runStoreIO store (Store.runTransaction (Tx.statement () countShardSinkStmt)) - -countShardSinkStmt :: Statement () Int -countShardSinkStmt = - preparable - "SELECT count(*) FROM shard_sink" - E.noParams - (D.singleRow (fromIntegral <$> D.column (D.nonNullable D.int8))) - -shardDeadLetterDetails :: Store.KirokuStore -> Text -> IO (Int, Maybe Text, Maybe Int) -shardDeadLetterDetails store subscription = - either (const (0, Nothing, Nothing)) id - <$> Store.runStoreIO store (Store.runTransaction (Tx.statement subscription shardDeadLetterDetailsStmt)) - -shardDeadLetterDetailsStmt :: Statement Text (Int, Maybe Text, Maybe Int) -shardDeadLetterDetailsStmt = - preparable - "SELECT count(*)::bigint, max(reason_summary), max(attempt_count) \ - \FROM kiroku.dead_letters \ - \WHERE subscription_name = $1 AND consumer_group_member = 0" - (E.param (E.nonNullable E.text)) - ( D.singleRow $ - (,,) - <$> (fromIntegral <$> D.column (D.nonNullable D.int8)) - <*> D.column (D.nullable D.text) - <*> (fmap fromIntegral <$> D.column (D.nullable D.int4)) - ) - --- The largest number of distinct workers that processed any single stream. 1 --- means perfectly disjoint ownership (no stream split across workers). -maxWorkersPerStream :: Store.KirokuStore -> IO Int -maxWorkersPerStream store = - either (const 0) id - <$> Store.runStoreIO store (Store.runTransaction (Tx.statement () maxWorkersPerStreamStmt)) - -maxWorkersPerStreamStmt :: Statement () Int -maxWorkersPerStreamStmt = - preparable - "SELECT COALESCE(MAX(c), 0) FROM \ - \(SELECT count(DISTINCT worker_tag) AS c FROM shard_sink GROUP BY stream_id) s" - E.noParams - (D.singleRow (fromIntegral <$> D.column (D.nonNullable D.int8))) - --- How many distinct workers processed at least one event (proves the work --- spread across the pool rather than monopolised by one worker). -distinctWorkers :: Store.KirokuStore -> IO Int -distinctWorkers store = - either (const 0) id - <$> Store.runStoreIO store (Store.runTransaction (Tx.statement () distinctWorkersStmt)) - -distinctWorkersStmt :: Statement () Int -distinctWorkersStmt = - preparable - "SELECT count(DISTINCT worker_tag) FROM shard_sink" - E.noParams - (D.singleRow (fromIntegral <$> D.column (D.nonNullable D.int8))) - --- Poll the sink count until it reaches @target@ or the timeout elapses. -waitUntilSinkCount :: Store.KirokuStore -> Int -> Int -> IO Bool -waitUntilSinkCount store target timeoutMicros = go (max 1 (timeoutMicros `div` step)) - where - step = 100_000 - go :: Int -> IO Bool - go 0 = (>= target) <$> shardSinkCount store - go n = do - c <- shardSinkCount store - if c >= target - then pure True - else threadDelay step >> go (n - 1) - --- Poll until at least @target@ shard rows have a live owner. Tests use this to --- join a second worker at a precise point in the one-bucket-per-pass ramp-up. -waitUntilOwnedShardCount :: Store.KirokuStore -> SubscriptionName -> Int -> Int -> IO Bool -waitUntilOwnedShardCount store sub target timeoutMicros = go (max 1 (timeoutMicros `div` step)) - where - step = 50_000 - go 0 = hasTarget - go n = do - reached <- hasTarget - if reached then pure True else threadDelay step >> go (n - 1) - hasTarget = do - rows <- either (const []) id <$> Store.runStoreIO store (Store.runTransaction (listShardOwnership sub)) - pure (length [() | (_, Just _, _) <- rows] >= target) - --- Poll the lease table until cooperative ownership has converged: every bucket --- owned, at least @minWorkers@ distinct owners, and no owner holding more than --- its fair share. This is the "balanced on the empty category" gate the --- failover test waits on before seeding, so the drain runs under stable --- membership. -waitShardsBalanced :: Store.KirokuStore -> SubscriptionName -> Int -> Int -> Int -> IO Bool -waitShardsBalanced store sub n minWorkers timeoutMicros = go (max 1 (timeoutMicros `div` step)) - where - step = 200_000 - go :: Int -> IO Bool - go 0 = isBalanced - go k = do - ok <- isBalanced - if ok then pure True else threadDelay step >> go (k - 1) - isBalanced :: IO Bool - isBalanced = do - rows <- either (const []) id <$> Store.runStoreIO store (Store.runTransaction (listShardOwnership sub)) - let owners = [w | (_, Just w, _) <- rows] - distinct = length (nubOrd owners) - perOwner = [length g | g <- groupByOwner owners] - fairShare = (n + max 1 distinct - 1) `div` max 1 distinct - pure (length rows == n && length owners == n && distinct >= minWorkers && all (<= fairShare) perOwner) - groupByOwner ws = [filter (== w) ws | w <- nubOrd ws] - nubOrd = Set.toList . Set.fromList - -waitShardsUnowned :: Store.KirokuStore -> SubscriptionName -> Int -> Int -> IO Bool -waitShardsUnowned store sub n timeoutMicros = go (max 1 (timeoutMicros `div` step)) - where - step = 100_000 - go 0 = isUnowned - go k = do - ok <- isUnowned - if ok then pure True else threadDelay step >> go (k - 1) - isUnowned = do - rows <- either (const []) id <$> Store.runStoreIO store (Store.runTransaction (listShardOwnership sub)) - pure (length rows == n && all (\(_, owner, _) -> isNothing owner) rows) - -workflowOwnedRowCounts :: (Store :> es) => Text -> Text -> Eff es (Int64, Int64, Int64, Int64, Int64, Int64) -workflowOwnedRowCounts name wid = - Store.runTransaction (Tx.statement (wid, name) workflowOwnedRowCountsStmt) - -workflowOwnedChildCount :: (Store :> es) => Text -> Text -> Eff es Int64 -workflowOwnedChildCount name wid = - Store.runTransaction (Tx.statement (wid, name, wid, name) workflowOwnedChildCountStmt) - -workflowWakeAfter :: (Store :> es) => WorkflowName -> WorkflowId -> Eff es (Maybe UTCTime) -workflowWakeAfter (WorkflowName name) (WorkflowId wid) = - Store.runTransaction (Tx.statement (wid, name) workflowWakeAfterStmt) - -insertGcTimerStmt :: Statement (UUID, Text, Text, UTCTime, Value, Text) () -insertGcTimerStmt = - preparable - """ - INSERT INTO keiro.keiro_timers - (timer_id, process_manager_name, correlation_id, fire_at, payload, status) - VALUES ($1, $2, $3, $4, $5, $6) - """ - ( contrazip6 - (E.param (E.nonNullable E.uuid)) - (E.param (E.nonNullable E.text)) - (E.param (E.nonNullable E.text)) - (E.param (E.nonNullable E.timestamptz)) - (E.param (E.nonNullable E.jsonb)) - (E.param (E.nonNullable E.text)) - ) - D.noResult - -deleteGcStepsStmt :: Statement (Text, Text) () -deleteGcStepsStmt = - preparable - """ - DELETE FROM keiro.keiro_workflow_steps - WHERE workflow_id = $1 AND workflow_name = $2 - """ - ( contrazip2 - (E.param (E.nonNullable E.text)) - (E.param (E.nonNullable E.text)) - ) - D.noResult - -deleteWorkflowInstanceStmt :: Statement (Text, Text) () -deleteWorkflowInstanceStmt = - preparable - """ - DELETE FROM keiro.keiro_workflows - WHERE workflow_id = $1 AND workflow_name = $2 - """ - ( contrazip2 - (E.param (E.nonNullable E.text)) - (E.param (E.nonNullable E.text)) - ) - D.noResult - -workflowWakeAfterStmt :: Statement (Text, Text) (Maybe UTCTime) -workflowWakeAfterStmt = - preparable - """ - SELECT wake_after - FROM keiro.keiro_workflows - WHERE workflow_id = $1 AND workflow_name = $2 - """ - ( contrazip2 - (E.param (E.nonNullable E.text)) - (E.param (E.nonNullable E.text)) - ) - (maybe Nothing id <$> D.rowMaybe (D.column (D.nullable D.timestamptz))) - -workflowOwnedRowCountsStmt :: Statement (Text, Text) (Int64, Int64, Int64, Int64, Int64, Int64) -workflowOwnedRowCountsStmt = - preparable - """ - SELECT - (SELECT count(*) FROM keiro.keiro_workflows WHERE workflow_id = $1 AND workflow_name = $2), - (SELECT count(*) FROM keiro.keiro_workflow_steps WHERE workflow_id = $1 AND workflow_name = $2), - (SELECT count(*) FROM keiro.keiro_awakeables WHERE owner_workflow_id = $1 AND owner_workflow_name = $2), - (SELECT count(*) FROM keiro.keiro_workflow_children - WHERE (parent_id = $1 AND parent_name = $2) OR (child_id = $1 AND child_name = $2)), - (SELECT count(*) FROM keiro.keiro_timers - WHERE correlation_id = $1 AND process_manager_name = $2 AND payload->>'kind' = 'keiro.workflow.sleep'), - (SELECT count(*) - FROM keiro.keiro_snapshots s - JOIN streams st ON st.stream_id = s.stream_id - WHERE st.stream_name = 'wf:' || $2 || '-' || $1) - """ - ( contrazip2 - (E.param (E.nonNullable E.text)) - (E.param (E.nonNullable E.text)) - ) - ( D.singleRow $ - (,,,,,) - <$> D.column (D.nonNullable D.int8) - <*> D.column (D.nonNullable D.int8) - <*> D.column (D.nonNullable D.int8) - <*> D.column (D.nonNullable D.int8) - <*> D.column (D.nonNullable D.int8) - <*> D.column (D.nonNullable D.int8) - ) - -workflowOwnedChildCountStmt :: Statement (Text, Text, Text, Text) Int64 -workflowOwnedChildCountStmt = - preparable - """ - SELECT count(*) - FROM keiro.keiro_workflow_children - WHERE (parent_id = $1 AND parent_name = $2) - OR (child_id = $3 AND child_name = $4) - """ - ( contrazip4 - (E.param (E.nonNullable E.text)) - (E.param (E.nonNullable E.text)) - (E.param (E.nonNullable E.text)) - (E.param (E.nonNullable E.text)) - ) - (D.singleRow (D.column (D.nonNullable D.int8))) +module Main + ( main, + ) +where + +import Contravariant.Extras (contrazip2, contrazip3, contrazip4, contrazip5, contrazip6) +import Control.Concurrent (forkIO, killThread, threadDelay) +import Control.Concurrent.MVar (MVar, modifyMVar, newEmptyMVar, newMVar, putMVar, readMVar, takeMVar, tryPutMVar) +import Control.Concurrent.STM (atomically, putTMVar) +import Control.Exception (ErrorCall, Exception, SomeException, displayException, evaluate, finally, throwIO, try) +import Data.Aeson (object, withObject, (.:), (.:?)) +import Data.Aeson qualified as Aeson +import Data.Aeson.KeyMap qualified as KeyMap +import Data.Aeson.Types (parseEither) +import Data.ByteString (ByteString) +import Data.IORef (IORef, atomicModifyIORef', modifyIORef', newIORef, readIORef, writeIORef) +import Data.Int (Int32) +import Data.List (isInfixOf) +import Data.Map.Strict qualified as Map +import Data.Monoid (mempty) +import Data.Set qualified as Set +import Data.Text qualified as Text +import Data.Text.Encoding qualified as TE +import Data.Time (NominalDiffTime, UTCTime (..), addUTCTime, diffUTCTime, secondsToDiffTime) +import Data.Time.Calendar (Day (ModifiedJulianDay)) +import Data.UUID (UUID, fromString, fromWords64) +import Data.UUID qualified as UUID +import Data.Vector qualified as Vector +import Data.Word (Word64) +import Effectful (Eff, IOE, (:>)) +import Effectful.Error.Static (Error, throwError) +import Effectful.Exception qualified as EffException +import GHC.Conc (ThreadStatus (..), threadStatus) +import Hasql.Decoders qualified as D +import Hasql.Encoders qualified as E +import Hasql.Statement (Statement, preparable) +import Keiki.Core + ( Edge (..), + HsPred (..), + InCtor (..), + IndexN, + RegFile (..), + SymTransducer (..), + Update (..), + WireCtor (..), + inpCtor, + lit, + matchInCtor, + oNil, + pack, + proj, + (*:), + (.==), + ) +import Keiki.Core qualified as Keiki +import Keiki.Generics (emptyRegFile) +import Keiki.Operators qualified as K +import Keiki.Shape (CanonicalStateShape) +import Keiro +import Keiro qualified as KeiroRoot +import Keiro.Codec.Nominal + ( NominalBinding (..), + NominalFixture (..), + NominalFixtureCases (..), + nominalDomainRoundTrip, + nominalRepresentationRoundTrip, + ) +import Keiro.Codec.Structural + ( StructuralBinding (..), + bindingDomainRoundTrip, + bindingShapeRoundTrip, + decodeViaBinding, + encodeViaBinding, + ) +import Keiro.Connection (ensureProjectionSchema, qualifyTable, withProjectionSchema) +import Keiro.DeadLetter + ( DispatchDeadLetter (..), + DispatcherKind (..), + listDispatchDeadLetters, + recordDispatchDeadLetter, + ) +import Keiro.DeadLetter.Replay + ( ReplayOutcome (..), + ReplayResult (..), + listSubscriptionDeadLetters, + replaySubscriptionDeadLetters, + ) +import Keiro.EventStream (Terminality (..)) +import Keiro.EventStream.Validate + ( EventStreamWarning (..), + ValidatedEventStream, + mkEventStream, + mkEventStreamOrThrow, + mkEventStreamUnchecked, + mkEventStreamWith, + validateEventStream, + ) +import Keiro.Inbox + ( InboxDedupePolicy (..), + InboxError (..), + InboxPersistence (..), + InboxResult (..), + InboxStatus (..), + KafkaDeliveryRef (..), + garbageCollectCompleted, + listInbox, + lookupInbox, + markFailedTx, + runInboxTransaction, + runInboxTransactionBatch, + runInboxTransactionWith, + runInboxTransactionWithRetries, + runInboxTransactionWithRetriesWith, + sampleInboxBacklog, + ) +import Keiro.Inbox.Kafka qualified as InboxKafka +import Keiro.Integration.Event + ( IntegrationContentType (..), + IntegrationEvent (..), + SchemaReference (..), + TraceContext (..), + decodeJsonIntegrationEvent, + encodeJsonIntegrationEvent, + headerContentType, + headerMessageId, + headerSchemaSubject, + headerSchemaVersion, + headerSourceEventId, + headerSourceGlobalPosition, + headerTraceParent, + integrationHeaders, + integrationPayload, + parseContentType, + ) +import Keiro.Integration.Event qualified as IntegrationEvent +import Keiro.Outbox + ( BackoffSchedule (..), + ExponentialBackoffOptions (..), + IntegrationEventDraft (..), + IntegrationProducer (..), + IntegrationProducerConfigError (..), + OrderingPolicy (..), + OutboxId (..), + OutboxPublishConfigError (..), + OutboxRow (..), + OutboxStatus (..), + PublishOutcome (..), + claimOutboxBatch, + defaultMaintenanceOptions, + defaultPublishOptions, + draftToEvent, + enqueueIntegrationEventTx, + freshOutboxId, + garbageCollectSent, + lookupOutbox, + markOutboxSent, + mintIntegrationEvent, + mkIntegrationProducer, + mkOutboxPublishOptions, + outboxMaintenancePass, + publishClaimedOutbox, + sampleOutboxBacklog, + ) +import Keiro.Outbox.Kafka qualified as OutboxKafka +import Keiro.Outbox.Schema (markOutboxFailedTx) +import Keiro.Prelude +import Keiro.ProcessManager +import Keiro.Projection +import Keiro.ReadModel +import Keiro.ReadModel.Rebuild qualified as Rebuild +import Keiro.ReplayAudit qualified as ReplayAudit +import Keiro.Snapshot.Policy (shouldSnapshot, shouldSnapshotSpan) +import Keiro.Stream qualified as Stream +import Keiro.Subscription.Shard + ( ShardCountMismatch (..), + ShardLease (..), + WorkerId (..), + ensureShards, + fairShareTarget, + ) +import Keiro.Subscription.Shard.Schema + ( claimShardsTx, + ensureShardRows, + listShardOwnership, + releaseShardsTx, + renewLeaseTx, + ) +import Keiro.Subscription.Shard.Worker + ( ShardAck (..), + ShardWorkerError (..), + ShardedWorkerConfigError (..), + ShardedWorkerOptions (..), + acquireOutcome, + defaultShardedWorkerOptions, + mkShardedWorkerOptions, + reconcileShardsOnce, + runShardedSubscriptionGroup, + runShardedSubscriptionGroupAck, + ) +import Keiro.Telemetry qualified as Telemetry +import Keiro.Test.Postgres + ( StoreRunner (..), + withFreshResourceStore, + withFreshResourceStoreWith, + withFreshStore, + withFreshStoreWith, + withFreshStores2, + withMigratedSuite, + ) +import Keiro.Timer +import Keiro.Wake + ( WakeReason (..), + WakeSignal (..), + neverWake, + wakeSignalFromStore, + ) +import Keiro.Workflow + ( LeaseHeartbeat (..), + PatchId (..), + StepName (..), + Workflow, + WorkflowError (..), + WorkflowId (..), + WorkflowIdentityError (..), + WorkflowJournalEvent (StepRecorded, WorkflowCancelled, WorkflowCompleted, WorkflowContinuedAsNew, WorkflowFailed), + WorkflowLeaseLost (..), + WorkflowName (..), + WorkflowOutcome (..), + appendJournalEntry, + appendJournalEntryReturningId, + awaitStep, + awakeableAllocStepPrefix, + awakeableStepPrefix, + continueAsNew, + currentGeneration, + defaultWorkflowRunOptions, + findUnfinishedWorkflowIds, + loadStepIndex, + mkWorkflowId, + mkWorkflowName, + patch, + patchSetStepName, + patchStepName, + restoreSeed, + runWorkflow, + runWorkflowWith, + step, + stepExists, + workflowGenerationStreamName, + workflowJournalCodec, + ) +import Keiro.Workflow.Awakeable + ( AwakeableId (..), + WorkflowAwakeableCancelled (..), + awakeableIdText, + awakeableIdToUuid, + awakeableNamed, + cancelAwakeable, + deterministicAwakeableId, + signalAwakeable, + signalAwakeableFrom, + ) +import Keiro.Workflow.Awakeable.Schema qualified as Awk +import Keiro.Workflow.Child + ( ChildHandle (..), + WorkflowChildCancelled (..), + WorkflowChildFailed (..), + awaitChild, + cancelChild, + childCompletionHook, + childResultStepName, + childSpawnStepName, + runChildWorkflow, + spawnChild, + ) +import Keiro.Workflow.Child.Schema qualified as Child +import Keiro.Workflow.Gc qualified as WorkflowGc +import Keiro.Workflow.Instance qualified as Instance +import Keiro.Workflow.Resume + ( ResumeLogEvent (..), + ResumeSummary (..), + WorkflowDef (..), + defaultWorkflowResumeOptions, + emptyResumeSummary, + resumeWorkflowsOnce, + runPollLoopWith, + runWorkflowResumeWorkerPush, + runWorkflowResumeWorkerWith, + ) +import Keiro.Workflow.Sleep + ( matchSleepTimerGeneration, + parseSleepPayload, + runWorkflowTimerWorker, + sleepNamed, + sleepStepName, + sleepTimerId, + sleepTimerPayload, + workflowSleepFireAction, + ) +import Keiro.Workflow.Snapshot + ( loadWorkflowSnapshot, + workflowStateCodec, + ) +import Kiroku.Store qualified as Store +import Kiroku.Store.Effect (Store) +import Kiroku.Store.SQL qualified as KirokuSQL +import Kiroku.Store.Subscription.Stream (AckItem (..), subscriptionAckStream) +import Kiroku.Store.Subscription.Types + ( SubscriptionName (..), + SubscriptionTarget (..), + ) +import Kiroku.Store.Subscription.Types qualified as KirokuSub +import Kiroku.Store.Types + ( CategoryName (..), + EventData (..), + EventId (..), + EventType (..), + ExpectedVersion (..), + GlobalPosition (..), + RecordedEvent (..), + StreamId (..), + StreamName (..), + StreamVersion (..), + ) +import OpenTelemetry.Attributes (Attribute (..), Attributes, PrimitiveAttribute (..), lookupAttribute) +import OpenTelemetry.Attributes.Key (AttributeKey, unkey) +import OpenTelemetry.Exporter.InMemory.Metric (inMemoryMetricExporter) +import OpenTelemetry.Exporter.InMemory.Span (inMemoryListExporter) +import OpenTelemetry.Exporter.Metric + ( GaugeDataPoint (..), + HistogramDataPoint (..), + MetricExport (..), + NumberValue (..), + ResourceMetricsExport (..), + ScopeMetricsExport (..), + SumDataPoint (..), + ) +import OpenTelemetry.MeterProvider + ( SdkMeterProviderOptions (..), + createMeterProvider, + defaultSdkMeterProviderOptions, + ) +import OpenTelemetry.Metric.Core + ( forceFlushMeterProvider, + getMeter, + ) +import OpenTelemetry.Resource (emptyMaterializedResources) +import OpenTelemetry.Trace + ( SpanStatus (..), + createTracerProvider, + emptyTracerProviderOptions, + makeTracer, + shutdownTracerProvider, + tracerOptions, + ) +import OpenTelemetry.Trace.Core + ( ImmutableSpan (..), + Span, + SpanContext (..), + SpanHot (..), + SpanKind, + getSpanContext, + ) +import Shibuya.Adapter (Adapter (..)) +import Shibuya.Core.Ack (AckDecision (..), DeadLetterReason (..), HaltReason (..), RetryDelay (..)) +import Shibuya.Core.AckHandle (AckHandle (..)) +import Shibuya.Core.Ingested (Ingested (..)) +import Shibuya.Core.Types (Envelope (..)) +import Streamly.Data.Stream qualified as Streamly +import System.Exit (ExitCode (..)) +import System.Process (readProcessWithExitCode) +import System.Timeout (timeout) +import Test.Hspec +import "hasql-transaction" Hasql.Transaction qualified as Tx + +main :: IO () +main = withMigratedSuite $ \fixture -> hspec $ do + describe "Keiro" $ do + it "exposes the scaffold version" $ + KeiroRoot.version `shouldBe` ("0.4.0.0" :: Text) + + describe "Keiro.Telemetry metrics" $ do + it "records instrument names and values through an SDK meter" $ do + (exporter, ref) <- inMemoryMetricExporter + (provider, _env) <- + createMeterProvider + emptyMaterializedResources + defaultSdkMeterProviderOptions {metricExporter = Just exporter} + meter <- getMeter provider Telemetry.keiroInstrumentationLibrary + metrics <- Telemetry.newKeiroMetrics meter + let h = Just metrics + -- A counter (monotonic sum), a gauge (last value wins), a histogram. + Telemetry.recordOutboxPublished h 3 + Telemetry.recordOutboxPublished h 2 + Telemetry.recordOutboxBacklog h 7 + Telemetry.recordInboxDuplicates h 1 + Telemetry.recordTimerFireLag h 12.5 + _ <- forceFlushMeterProvider provider Nothing + exported <- readIORef ref + let scalars = flattenScalarPoints exported + hists = flattenHistogramPoints exported + -- The counter accumulated 3 + 2 = 5. + lookup "keiro.outbox.published" scalars `shouldBe` Just (IntNumber 5) + -- The gauge holds its last recorded value. + lookup "keiro.outbox.backlog" scalars `shouldBe` Just (IntNumber 7) + -- The duplicate counter holds 1. + lookup "keiro.inbox.duplicates" scalars `shouldBe` Just (IntNumber 1) + -- The histogram saw one observation summing to 12.5. + let lag = [(c, s) | (n, c, s) <- hists, n == "keiro.timer.fire.lag"] + lag `shouldBe` [(1, 12.5)] + -- Instruments we never recorded export no points. + lookup "keiro.timer.stuck" scalars `shouldBe` Nothing + + it "records nothing through a Nothing handle" $ do + (exporter, ref) <- inMemoryMetricExporter + (provider, _env) <- + createMeterProvider + emptyMaterializedResources + defaultSdkMeterProviderOptions {metricExporter = Just exporter} + -- A Nothing handle is the no-op path: helpers must short-circuit. + let h = Nothing + Telemetry.recordOutboxPublished h 99 + Telemetry.recordOutboxBacklog h 99 + Telemetry.recordTimerFireLag h 99.0 + _ <- forceFlushMeterProvider provider Nothing + exported <- readIORef ref + flattenScalarPoints exported `shouldBe` [] + flattenHistogramPoints exported `shouldBe` [] + + describe "Kiroku retry exhaustion observability" $ do + it "dead-letters after the configured delivery bound, emits the metric, and advances" $ do + (exporter, metricsRef) <- inMemoryMetricExporter + (provider, _env) <- + createMeterProvider + emptyMaterializedResources + defaultSdkMeterProviderOptions {metricExporter = Just exporter} + meter <- getMeter provider Telemetry.keiroInstrumentationLibrary + metrics <- Telemetry.newKeiroMetrics meter + forwarded <- newIORef (0 :: Int) + let observe _ = modifyIORef' forwarded (+ 1) + installBridge settings = + settings + & #eventHandler + .~ Just (Telemetry.kirokuEventBridge (Just metrics) observe) + withFreshStoreWith fixture installBridge $ \store -> do + total <- seedOrders store 1 2 + total `shouldBe` 2 + let subName = SubscriptionName "orders-retry-exhaustion" + subConfig = + ( KirokuSub.defaultSubscriptionConfig + subName + (Category (CategoryName "orders")) + (\_ -> pure KirokuSub.Continue) + ) + { KirokuSub.retryPolicy = KirokuSub.RetryPolicy 2 + } + pull label source = do + result <- timeout 5_000_000 (Streamly.uncons source) + case result of + Just (Just itemAndRest) -> pure itemAndRest + Just Nothing -> fail (label <> ": subscription ended early") + Nothing -> fail (label <> ": timed out waiting for delivery") + number item = + parseEither + (withObject "OrderPlaced" (.: "n")) + (ackEvent item ^. #payload) + (stream0, cancelStream) <- subscriptionAckStream store subConfig 4 + ( do + (first, stream1) <- pull "initial poison delivery" stream0 + ackAttempt first `shouldBe` 0 + number first `shouldBe` Right (0 :: Int) + atomically $ + putTMVar + (ackReply first) + (KirokuSub.Retry (KirokuSub.RetryDelay 0)) + + (retry, stream2) <- pull "poison redelivery" stream1 + ackAttempt retry `shouldBe` 1 + ackEvent retry ^. #eventId `shouldBe` ackEvent first ^. #eventId + atomically $ + putTMVar + (ackReply retry) + (KirokuSub.Retry (KirokuSub.RetryDelay 0)) + + (next, stream3) <- pull "event after exhausted poison" stream2 + ackAttempt next `shouldBe` 0 + number next `shouldBe` Right (1 :: Int) + ackEvent next ^. #eventId `shouldNotBe` ackEvent first ^. #eventId + atomically (putTMVar (ackReply next) KirokuSub.Stop) + ended <- timeout 5_000_000 (Streamly.uncons stream3) + case ended of + Just Nothing -> pure () + Just (Just _) -> expectationFailure "subscription delivered after Stop" + Nothing -> expectationFailure "subscription did not stop after the final acknowledgement" + ) + `finally` cancelStream + + Right rows <- + Store.runStoreIO store $ + Store.runTransaction $ + Tx.statement + ("orders-retry-exhaustion", 0) + KirokuSQL.readDeadLettersStmt + case Vector.toList rows of + [row] -> do + row ^. #deadLetterReason + `shouldBe` object + [ "kind" Aeson..= ("max_attempts_exceeded" :: Text), + "attempts" Aeson..= (2 :: Int) + ] + row ^. #deadLetterReasonSummary `shouldBe` "max retry attempts exceeded (2)" + row ^. #deadLetterAttemptCount `shouldBe` 2 + other -> expectationFailure ("expected one Kiroku dead letter, got " <> show (Vector.length rows) <> ": " <> show other) + + _ <- forceFlushMeterProvider provider Nothing + exported <- readIORef metricsRef + lookup "keiro.subscription.deadlettered" (flattenScalarPoints exported) + `shouldBe` Just (IntNumber 1) + readIORef forwarded >>= (`shouldSatisfy` (> 1)) + + describe "Keiro.Stream" $ do + it "wraps and unwraps kiroku stream names" $ do + let orderStream = stream "order-123" :: Stream OrderStream + Stream.streamName orderStream `shouldBe` StreamName "order-123" + Stream.streamName (mapStreamName (\(StreamName name) -> StreamName (name <> "-archived")) orderStream) + `shouldBe` StreamName "order-123-archived" + + it "validates categories, rejecting the dash boundary and reserved names" $ do + fmap Stream.categoryText (Stream.category "incident" :: Either Stream.CategoryError (Stream.StreamCategory ())) + `shouldBe` Right "incident" + -- compound categories are camelCase; ':' (reserved for the wf: family) is also accepted + fmap Stream.categoryText (Stream.category "hospitalSurge" :: Either Stream.CategoryError (Stream.StreamCategory ())) + `shouldBe` Right "hospitalSurge" + fmap Stream.categoryText (Stream.category "wf:fulfillment" :: Either Stream.CategoryError (Stream.StreamCategory ())) + `shouldBe` Right "wf:fulfillment" + (Stream.category "" :: Either Stream.CategoryError (Stream.StreamCategory ())) + `shouldBe` Left Stream.CategoryEmpty + (Stream.category "hospital-surge" :: Either Stream.CategoryError (Stream.StreamCategory ())) + `shouldBe` Left (Stream.CategoryContainsSeparator "hospital-surge") + (Stream.category "$all" :: Either Stream.CategoryError (Stream.StreamCategory ())) + `shouldBe` Left (Stream.CategoryReserved "$all") + (Stream.category "ord ers" :: Either Stream.CategoryError (Stream.StreamCategory ())) + `shouldBe` Left (Stream.CategoryContainsIllegalChar ' ' "ord ers") + (Stream.category "ord\ners" :: Either Stream.CategoryError (Stream.StreamCategory ())) + `shouldBe` Left (Stream.CategoryContainsIllegalChar '\n' "ord\ners") + + it "builds entity streams that round-trip through kiroku's category rule" $ do + let cat = Stream.categoryUnsafe "orders" :: Stream.StreamCategory OrderStream + Stream.streamName (Stream.entityStream cat "1") `shouldBe` StreamName "orders-1" + Stream.categoryName cat `shouldBe` CategoryName "orders" + -- The category keiro reports equals kiroku's own parse of the produced + -- name, even when the id segment itself contains a dash. + Store.categoryName (Stream.streamName (Stream.entityStream cat "a-b-c")) + `shouldBe` Stream.categoryName cat + + it "entityStreamId renders ids via StreamIdSegment (Text and String)" $ do + let cat = Stream.categoryUnsafe "orders" :: Stream.StreamCategory OrderStream + Stream.streamName (Stream.entityStreamId cat ("o-1" :: Text)) `shouldBe` StreamName "orders-o-1" + Stream.streamName (Stream.entityStreamId cat ("o-1" :: String)) `shouldBe` StreamName "orders-o-1" + + it "rejects blank entity stream id segments" $ do + let cat = Stream.categoryUnsafe "orders" :: Stream.StreamCategory OrderStream + evaluate (Stream.streamName (Stream.entityStream cat "")) `shouldThrow` anyErrorCall + evaluate (Stream.streamName (Stream.entityStream cat " ")) `shouldThrow` anyErrorCall + + describe "Keiro.DeadLetter" $ around (withFreshStore fixture) $ do + it "records a dispatch dead letter idempotently" $ \storeHandle -> do + let deadLetter = + DispatchDeadLetter + { dispatcherKind = DispatcherProcessManager, + dispatcherName = "orders-pm", + correlationId = "order-42", + sourceEventId = EventId sampleUuid, + sourceGlobalPosition = GlobalPosition 17, + emitIndex = 0, + targetStreamName = StreamName "orders-42", + errorClass = "command_rejected", + errorDetail = Text.replicate 1100 "x", + attemptCount = 2 + } + Right rows <- + Store.runStoreIO storeHandle $ do + recordDispatchDeadLetter deadLetter + recordDispatchDeadLetter deadLetter + listDispatchDeadLetters "orders-pm" + case rows of + [row] -> do + row ^. #dispatcherKind `shouldBe` DispatcherProcessManager + row ^. #dispatcherName `shouldBe` "orders-pm" + row ^. #correlationId `shouldBe` "order-42" + row ^. #sourceEventId `shouldBe` EventId sampleUuid + row ^. #sourceGlobalPosition `shouldBe` GlobalPosition 17 + row ^. #emitIndex `shouldBe` 0 + row ^. #targetStreamName `shouldBe` StreamName "orders-42" + row ^. #errorClass `shouldBe` "command_rejected" + Text.length (row ^. #errorDetail) `shouldBe` 1024 + row ^. #attemptCount `shouldBe` 2 + other -> expectationFailure ("expected one idempotent dead-letter row, got " <> show other) + + describe "Keiro.Codec" $ do + it "encodes current events with type tags and schema-version metadata" $ do + encoded <- shouldBeRight (encodeForAppend orderCodec (OrderPlaced "order-123" 5)) + encoded ^. #eventType `shouldBe` EventType "OrderPlaced" + encoded ^. #payload `shouldBe` object ["orderId" Aeson..= ("order-123" :: Text), "quantity" Aeson..= (5 :: Int)] + extractSchemaVersion (recordedFrom encoded) `shouldBe` Right 2 + + it "round-trips current events" $ do + encoded <- shouldBeRight (encodeForAppend orderCodec (OrderPlaced "order-123" 5)) + decodeRecorded orderCodec (recordedFrom encoded) `shouldBe` Right (OrderPlaced "order-123" 5) + + it "decodes by the stored tag, not by payload shape (H1)" $ do + let recorded = + recordedFrom + EventData + { eventId = Nothing, + eventType = EventType "CounterAudited", + payload = object ["amount" Aeson..= (5 :: Int)], + metadata = Just (metadataForOrDie 1 Nothing), + causationId = Nothing, + correlationId = Nothing + } + decodeRecorded counterCodec recorded `shouldBe` Right (CounterAudited 5) + + it "runs upcasters in source-version order" $ + decodeRaw orderCodec (EventType "OrderPlaced") 1 (object ["orderId" Aeson..= ("order-123" :: Text), "qty" Aeson..= (5 :: Int)]) + `shouldBe` Right (OrderPlaced "order-123" 5) + + it "rejects gaps in upcaster chains" $ + decodeRaw gappyCodec (EventType "OrderPlaced") 1 (object ["orderId" Aeson..= ("order-123" :: Text), "qty" Aeson..= (5 :: Int)]) + `shouldBe` Left (GapInUpcasterChain 2 3) + + it "validates codec construction invariants" $ do + fmap (const ()) (mkCodec (orderCodec {schemaVersion = 0})) `shouldBe` Left (CodecSchemaVersionInvalid 0) + fmap (const ()) (mkCodec (orderCodec {eventTypes = EventType "OrderPlaced" :| [EventType "OrderPlaced"]})) + `shouldBe` Left (CodecDuplicateEventTypes [EventType "OrderPlaced"]) + fmap (const ()) (mkCodec (orderCodec {schemaVersion = 3, upcasters = [(1, const upcastOrderPlacedV1), (1, const upcastOrderPlacedV1)]})) + `shouldBe` Left (CodecDuplicateUpcasterSources [1]) + fmap (const ()) (mkCodec (orderCodec {schemaVersion = 3, upcasters = [(1, const upcastOrderPlacedV1)]})) + `shouldBe` Left (CodecUpcasterChainIncomplete [2] 3) + case mkCodec orderCodec of + Right _ -> pure () + Left err -> expectationFailure ("expected orderCodec to validate, got " <> show err) + + it "rejects future-version, malformed metadata, and incomplete upcaster chains" $ do + let v1Payload = object ["orderId" Aeson..= ("order-123" :: Text), "qty" Aeson..= (5 :: Int)] + earlyEndCodec = + orderCodec + { schemaVersion = 4, + upcasters = [(1, const upcastOrderPlacedV1), (2, const Right)] + } + decodeRaw orderCodec (EventType "OrderPlaced") 3 v1Payload + `shouldBe` Left (VersionAhead 3 2) + decodeRaw earlyEndCodec (EventType "OrderPlaced") 1 v1Payload + `shouldBe` Left (IncompleteUpcasterChain 3 4) + + let malformedStamp = + recordedFrom + EventData + { eventId = Nothing, + eventType = EventType "OrderPlaced", + payload = object ["orderId" Aeson..= ("order-123" :: Text), "quantity" Aeson..= (5 :: Int)], + metadata = Just (object ["schemaVersion" Aeson..= ("2" :: Text)]), + causationId = Nothing, + correlationId = Nothing + } + extractSchemaVersion malformedStamp + `shouldBe` Left (MalformedSchemaVersionStamp (Aeson.String "2")) + fmap (const ()) (encodeForAppendWithMetadata orderCodec (Just (Aeson.String "x")) (OrderPlaced "order-123" 5)) + `shouldBe` Left (NonObjectCallerMetadata (Aeson.String "x")) + + it "rejects recorded events with unknown type tags" $ do + let encoded = + recordedFrom + EventData + { eventId = Nothing, + eventType = EventType "OrderCancelled", + payload = object ["orderId" Aeson..= ("order-123" :: Text)], + metadata = Just (metadataForOrDie 2 Nothing), + causationId = Nothing, + correlationId = Nothing + } + decodeRecorded orderCodec encoded + `shouldBe` Left (UnknownEventType (EventType "OrderCancelled") [EventType "OrderPlaced"]) + + describe "Keiro.Codec.Structural" $ do + let pairBinding :: StructuralBinding (Int, Bool) (Bool, Int) + pairBinding = + StructuralBinding + { bindingToShape = \(amount, enabled) -> (enabled, amount), + bindingFromShape = \(enabled, amount) -> (amount, enabled) + } + encodePairShape (enabled, amount) = + object ["enabled" Aeson..= enabled, "amount" Aeson..= amount] + decodePairShape value = + case parseEither (withObject "PairShape" $ \objectValue -> (,) <$> objectValue .: "enabled" <*> objectValue .: "amount") value of + Left err -> Left (Text.pack err) + Right shape -> Right shape + + it "checks both total binding laws" $ do + bindingDomainRoundTrip pairBinding (7, True) `shouldBe` True + bindingShapeRoundTrip pairBinding (False, 9) `shouldBe` True + + it "delegates encoding to the generated shape codec" $ + encodeViaBinding pairBinding encodePairShape (7, True) + `shouldBe` object ["enabled" Aeson..= True, "amount" Aeson..= (7 :: Int)] + + it "propagates only shape decode failures before total construction" $ do + let encoded = object ["enabled" Aeson..= False, "amount" Aeson..= (9 :: Int)] + decodeViaBinding pairBinding decodePairShape encoded `shouldBe` Right (9, False) + decodeViaBinding pairBinding (const (Left "shape-error")) Aeson.Null + `shouldBe` Left "shape-error" + + describe "Keiro.Codec.Nominal" $ do + let swappedBinding :: NominalBinding (Int, Bool) (Bool, Int) + swappedBinding = + NominalBinding + { nominalToRepresentation = \(amount, enabled) -> (enabled, amount), + nominalFromRepresentation = \(enabled, amount) -> (amount, enabled) + } + fixtures = + NominalFixtureCases + ( NominalFixture "enabled" (object ["enabled" Aeson..= True, "amount" Aeson..= (7 :: Int)]) (7, True) + :| [NominalFixture "disabled" (object ["enabled" Aeson..= False, "amount" Aeson..= (9 :: Int)]) (9, False)] + ) + + it "checks both total nominal binding laws" $ do + nominalDomainRoundTrip swappedBinding (7, True) `shouldBe` True + nominalRepresentationRoundTrip swappedBinding (False, 9) `shouldBe` True + + it "retains labelled expected-wire fixtures" $ + nominalFixtureCases fixtures + `shouldBe` ( NominalFixture "enabled" (object ["enabled" Aeson..= True, "amount" Aeson..= (7 :: Int)]) (7, True) + :| [NominalFixture "disabled" (object ["enabled" Aeson..= False, "amount" Aeson..= (9 :: Int)]) (9, False)] + ) + + describe "Keiro.EventStream" $ do + it "constructs an author-facing EventStream contract" $ do + let contract = + EventStream + { transducer = emptyTransducer, + initialState = Idle, + initialRegisters = RNil, + eventCodec = orderCodec, + resolveStreamName = \s -> Stream.streamName s, + snapshotPolicy = Never, + stateCodec = Nothing + } + typedStream = stream "order-123" :: Stream (EventStream () '[] OrderState OrderCommand OrderEvent) + contract ^. #initialState `shouldBe` Idle + (contract ^. #resolveStreamName) typedStream `shouldBe` StreamName "order-123" + + it "evaluates snapshot policies with explicit terminality" $ do + shouldSnapshot (Every 2) NotTerminal () (StreamVersion 0) `shouldBe` False + shouldSnapshot (Every 2) NotTerminal () (StreamVersion 2) `shouldBe` True + shouldSnapshot OnTerminal Terminal () (StreamVersion 1) `shouldBe` True + shouldSnapshot OnTerminal NotTerminal () (StreamVersion 1) `shouldBe` False + shouldSnapshot (Custom (\terminality _ _ -> terminality == Terminal)) Terminal () (StreamVersion 1) + `shouldBe` True + shouldSnapshot (Custom (\terminality _ _ -> terminality == Terminal)) NotTerminal () (StreamVersion 1) + `shouldBe` False + shouldSnapshotSpan (Every 3) NotTerminal () (StreamVersion 2) (StreamVersion 4) + `shouldBe` True + shouldSnapshotSpan (Every 3) NotTerminal () (StreamVersion 4) (StreamVersion 5) + `shouldBe` False + + it "rejects snapshot policies without a state codec" $ do + let contract :: CounterEventStream + contract = counterEventStreamDef {snapshotPolicy = Every 10, stateCodec = Nothing} + fmap (const ()) (mkEventStream "snapshotless" contract) + `shouldBe` Left [EventStreamWarning "snapshotless" "snapshotPolicy is set but stateCodec is Nothing; snapshots would never be written"] + + describe "EventStream replay-safety (validateEventStream)" $ do + it "every production-intent stream validates clean" $ + concat + [ validateEventStream "counter" counterEventStreamDef, + validateEventStream "counter-no-op" noOpCounterEventStreamDef, + validateEventStream "counter-multi" multiCounterEventStreamDef, + validateEventStream "counter-ambiguous" ambiguousCounterEventStreamDef, + validateEventStream "snapshot-counter" snapshotCounterEventStreamDef, + validateEventStream "snapshot-counter-multi" multiSnapshotCounterEventStreamDef, + validateEventStream "snapshot-counter-guarded" guardedSnapshotCounterEventStreamDef, + validateEventStream "pm-snapshot-counter" pmSnapshotCounterEventStreamDef, + validateEventStream "rejecting-counter" rejectingEventStreamDef + ] + `shouldBe` [] + + describe "mkEventStream" $ do + it "rejects duplicate upcaster sources at the stream boundary" $ do + let duplicateCodec = + counterCodec + { schemaVersion = 3, + upcasters = [(1, const Right), (1, const Right)] + } + duplicateStream = counterEventStreamDef {eventCodec = duplicateCodec} + case mkEventStream "duplicate-codec" duplicateStream of + Left warnings -> do + map eswStreamLabel warnings `shouldSatisfy` all (== "duplicate-codec") + map eswReason warnings `shouldSatisfy` any (Text.isInfixOf "duplicate upcaster source version(s): 1") + Right _ -> expectationFailure "expected mkEventStream to reject duplicate upcaster sources" + + it "rejects a missing upcaster rung at the stream boundary" $ do + let incompleteCodec = + counterCodec + { schemaVersion = 3, + upcasters = [(2, const Right)] + } + incompleteStream = counterEventStreamDef {eventCodec = incompleteCodec} + case mkEventStream "incomplete-codec" incompleteStream of + Left warnings -> do + map eswStreamLabel warnings `shouldSatisfy` all (== "incomplete-codec") + map eswReason warnings `shouldSatisfy` any (Text.isInfixOf "missing upcaster source version(s): 1") + Right _ -> expectationFailure "expected mkEventStream to reject an incomplete upcaster chain" + + it "includes the stream label when throwing for an invalid codec" $ do + let incompleteCodec = + counterCodec + { schemaVersion = 3, + upcasters = [(2, const Right)] + } + incompleteStream = counterEventStreamDef {eventCodec = incompleteCodec} + result <- try @ErrorCall (evaluate (mkEventStreamOrThrow "throwing-incomplete-codec" incompleteStream)) + case result of + Left err -> do + displayException err `shouldSatisfy` isInfixOf "throwing-incomplete-codec" + displayException err `shouldSatisfy` isInfixOf "missing upcaster source version(s): 1" + Right _ -> expectationFailure "expected mkEventStreamOrThrow to reject an incomplete upcaster chain" + + it "keeps invalid codecs available through the unchecked escape hatch" $ do + let duplicateCodec = + counterCodec + { schemaVersion = 3, + upcasters = [(1, const Right), (1, const Right)] + } + incompleteCodec = + counterCodec + { schemaVersion = 3, + upcasters = [(2, const Right)] + } + _ <- evaluate (mkEventStreamUnchecked counterEventStreamDef {eventCodec = duplicateCodec}) + _ <- evaluate (mkEventStreamUnchecked counterEventStreamDef {eventCodec = incompleteCodec}) + pure () + + it "rejects a hidden-input stream by label" $ do + let warns = validateEventStream "broken" brokenHiddenInputEventStream + warns `shouldNotBe` [] + map eswStreamLabel warns `shouldSatisfy` all (== "broken") + map eswReason warns `shouldSatisfy` any (Text.isInfixOf "hidden-input") + case mkEventStream "broken" brokenHiddenInputEventStream of + Left ws -> do + map eswStreamLabel ws `shouldSatisfy` all (== "broken") + map eswReason ws `shouldSatisfy` any (Text.isInfixOf "hidden-input") + Right _ -> expectationFailure "expected mkEventStream to reject the hidden-input stream" + + it "rejects a head-unrecoverable multi-event stream" $ + expectValidationWarning + "head-unrecoverable" + "head-unrecoverable" + headUnrecoverableEventStreamDef + + it "rejects replay inversion ambiguity" $ + expectValidationWarning + "inversion-ambiguity" + "inversion-ambiguity" + inversionAmbiguousEventStreamDef + + it "rejects an unguarded command-field read" $ + expectValidationWarning + "unguarded-input-read" + "unguarded-input-read" + unguardedInputReadEventStreamDef + + it "rejects a silent edge that writes registers" $ do + Keiki.validateTransducer Keiki.defaultValidationOptions stateChangingEpsilonTransducer + `shouldSatisfy` any isStateChangingEpsilon + expectValidationWarning + "state-changing-epsilon" + "state-changing-epsilon" + stateChangingEpsilonEventStreamDef + + it "rejects a silent edge that changes vertex" $ do + Keiki.validateTransducer Keiki.defaultValidationOptions silentMoveTransducer + `shouldSatisfy` any isStateChangingEpsilon + expectValidationWarning + "silent-move" + "state-changing-epsilon" + silentMoveEventStreamDef + + it "keeps replay-contract checks enabled when caller options weaken them" $ do + case mkEventStreamWith + Keiki.defaultValidationOptions {Keiki.checkStateChangingEpsilon = False} + "silent-move-weakened" + silentMoveEventStreamDef of + Left warnings -> + map eswReason warnings + `shouldSatisfy` any (Text.isInfixOf "state-changing-epsilon") + Right _ -> expectationFailure "expected the durable boundary to restore the state-changing-epsilon check" + case mkEventStreamWith + Keiki.defaultValidationOptions {Keiki.checkHeadRecoverability = False} + "head-unrecoverable-weakened" + headUnrecoverableEventStreamDef of + Left warnings -> + map eswReason warnings + `shouldSatisfy` any (Text.isInfixOf "head-unrecoverable") + Right _ -> expectationFailure "expected the durable boundary to restore the head-recoverability check" + + it "provides a loudly named unchecked escape hatch" $ do + _ <- evaluate (mkEventStreamUnchecked silentMoveEventStreamDef) + pure () + + it "accepts every production-intent stream" $ do + let expectAccepted label eventStream = + case mkEventStream label eventStream of + Right _ -> pure () + Left ws -> expectationFailure ("expected mkEventStream to accept " <> Text.unpack label <> ", got " <> show ws) + expectAccepted "counter" counterEventStreamDef + expectAccepted "counter-no-op" noOpCounterEventStreamDef + expectAccepted "counter-multi" multiCounterEventStreamDef + expectAccepted "counter-ambiguous" ambiguousCounterEventStreamDef + expectAccepted "snapshot-counter" snapshotCounterEventStreamDef + expectAccepted "snapshot-counter-multi" multiSnapshotCounterEventStreamDef + expectAccepted "snapshot-counter-guarded" guardedSnapshotCounterEventStreamDef + expectAccepted "pm-snapshot-counter" pmSnapshotCounterEventStreamDef + expectAccepted "rejecting-counter" rejectingEventStreamDef + + it "rejects a snapshot codec whose initial register file contains an uninitialized slot" $ do + case mkEventStream "uninitialized-snapshot" uninitializedSnapshotEventStreamDef of + Left warns -> do + map eswStreamLabel warns `shouldSatisfy` all (== "uninitialized-snapshot") + map eswReason warns `shouldSatisfy` any (Text.isInfixOf "cannot encode the initial state/registers") + map eswReason warns `shouldSatisfy` any (Text.isInfixOf "uninit: neverWritten") + Right _ -> expectationFailure "expected mkEventStream to reject an uninitialized snapshot register" + + it "accepts the same snapshot stream when every initial register is initialized" $ do + case mkEventStream "initialized-snapshot" initializedSnapshotEventStreamDef of + Right _ -> pure () + Left warns -> expectationFailure ("expected initialized snapshot registers to validate, got " <> show warns) + + it "rejects a bare EventStream at runCommand (compile-time)" $ do + (exitCode, _stdout, stderr) <- + readProcessWithExitCode + "cabal" + [ "exec", + "ghc", + "--", + "-fno-code", + "-package", + "keiro", + "test/ReplaySafetyTypeProbe.hs" + ] + "" + exitCode `shouldSatisfy` (/= ExitSuccess) + stderr `shouldSatisfy` ("ValidatedEventStream" `isInfixOf`) + + describe "Keiro.Command" $ around (withFreshStore fixture) $ do + it "creates a stream and appends the first command event" $ \storeHandle -> do + let target = stream "counter-command-create" :: Stream CounterEventStream + result <- + Store.runStoreIO storeHandle $ + runCommand defaultRunCommandOptions counterEventStream target (Add 2) + case result of + Right (Right commandResult) -> do + commandResult ^. #streamVersion `shouldBe` StreamVersion 1 + commandResult ^. #eventsAppended `shouldBe` 1 + commandResult ^. #globalPosition `shouldSatisfy` isJust + other -> expectationFailure ("expected successful command, got " <> show other) + Right recorded <- + Store.runStoreIO storeHandle $ + Store.readStreamForward (StreamName "counter-command-create") (StreamVersion 0) 10 + Vector.length recorded `shouldBe` 1 + traverse (decodeRecorded counterCodec) (Vector.toList recorded) + `shouldBe` Right [CounterAdded 2] + + it "reports no global position for a no-op after prior events" $ \storeHandle -> do + let target = stream "skip-command-no-op-position" :: Stream SkipEventStream + Right (Right appended) <- + Store.runStoreIO storeHandle $ + runCommand defaultRunCommandOptions skipEventStream target (SAdd 2) + appended ^. #globalPosition `shouldSatisfy` isJust + result <- + Store.runStoreIO storeHandle $ + runCommand defaultRunCommandOptions skipEventStream target SSkip + case result of + Right (Right noOp) -> do + noOp ^. #streamVersion `shouldBe` StreamVersion 1 + noOp ^. #eventsAppended `shouldBe` 0 + noOp ^. #globalPosition `shouldBe` Nothing + other -> expectationFailure ("expected successful no-op command, got " <> show other) + + it "surfaces runtime edge ambiguity without appending" $ \storeHandle -> do + (processor, spansRef) <- inMemoryListExporter + provider <- createTracerProvider [processor] emptyTracerProviderOptions + let tracer = makeTracer provider "keiro-test" tracerOptions + target = stream "counter-command-ambiguous" :: Stream CounterEventStream + options = defaultRunCommandOptions & #tracer ?~ tracer + result <- + Store.runStoreIO storeHandle $ + runCommand options ambiguousCounterEventStream target (Add 1) + _ <- shutdownTracerProvider provider Nothing + result `shouldBe` Right (Left (CommandAmbiguous [0, 1])) + Right recorded <- + Store.runStoreIO storeHandle $ + Store.readStreamForward (StreamName "counter-command-ambiguous") (StreamVersion 0) 10 + recorded `shouldBe` Vector.empty + spans <- traverse captureSpan =<< readIORef spansRef + case spans of + [sp] -> textAttr (csAttributes sp) "error.type" `shouldBe` Just "command_ambiguous" + other -> expectationFailure ("expected one span, got " <> show (length other)) + + it "rehydrates prior events before appending a second command event" $ \storeHandle -> do + let target = stream "counter-command-update" :: Stream CounterEventStream + Right (Right _) <- + Store.runStoreIO storeHandle $ + runCommand defaultRunCommandOptions counterEventStream target (Add 2) + result <- + Store.runStoreIO storeHandle $ + runCommand defaultRunCommandOptions counterEventStream target (Add 3) + case result of + Right (Right commandResult) -> + commandResult ^. #streamVersion `shouldBe` StreamVersion 2 + other -> expectationFailure ("expected successful second command, got " <> show other) + Right recorded <- + Store.runStoreIO storeHandle $ + Store.readStreamForward (StreamName "counter-command-update") (StreamVersion 0) 10 + traverse (decodeRecorded counterCodec) (Vector.toList recorded) + `shouldBe` Right [CounterAdded 2, CounterAdded 3] + + it "rejects hydration after truncation without a covering snapshot" $ \storeHandle -> do + let target = stream "counter-truncated-uncovered" :: Stream CounterEventStream + targetName = StreamName "counter-truncated-uncovered" + Right (Right _) <- + Store.runStoreIO storeHandle $ + runCommand defaultRunCommandOptions counterEventStream target (Add 1) + Right (Right _) <- + Store.runStoreIO storeHandle $ + runCommand defaultRunCommandOptions counterEventStream target (Add 2) + Right (Right _) <- + Store.runStoreIO storeHandle $ + runCommand defaultRunCommandOptions counterEventStream target (Add 3) + Right (Just _) <- + Store.runStoreIO storeHandle $ + Store.setStreamTruncateBefore targetName (StreamVersion 3) + result <- + Store.runStoreIO storeHandle $ + runCommand defaultRunCommandOptions counterEventStream target (Add 4) + case result of + Right (Left (HydrationGapDetected expected observed)) -> do + expected `shouldBe` StreamVersion 1 + observed `shouldBe` StreamVersion 3 + other -> expectationFailure ("expected HydrationGapDetected, got " <> show other) + + it "rejects hydration when truncation lands inside a command batch" $ \storeHandle -> do + let target = stream "counter-truncated-mid-batch" :: Stream CounterEventStream + targetName = StreamName "counter-truncated-mid-batch" + Right (Right _) <- + Store.runStoreIO storeHandle $ + runCommand defaultRunCommandOptions multiCounterEventStream target (Add 1) + Right (Just _) <- + Store.runStoreIO storeHandle $ + Store.setStreamTruncateBefore targetName (StreamVersion 2) + result <- + Store.runStoreIO storeHandle $ + runCommand defaultRunCommandOptions multiCounterEventStream target (Add 2) + case result of + Right (Left (HydrationGapDetected expected observed)) -> do + expected `shouldBe` StreamVersion 1 + observed `shouldBe` StreamVersion 2 + other -> expectationFailure ("expected HydrationGapDetected, got " <> show other) + + it "hydrates normally after truncation covered by a snapshot" $ \storeHandle -> do + let target = stream "counter-truncated-covered" :: Stream SnapshotCounterEventStream + targetName = StreamName "counter-truncated-covered" + Right (Right _) <- + Store.runStoreIO storeHandle $ + runCommand defaultRunCommandOptions snapshotCounterEventStream target (Add 1) + Right (Right _) <- + Store.runStoreIO storeHandle $ + runCommand defaultRunCommandOptions snapshotCounterEventStream target (Add 2) + Right (Just _) <- + Store.runStoreIO storeHandle $ + Store.setStreamTruncateBefore targetName (StreamVersion 2) + result <- + Store.runStoreIO storeHandle $ + runCommand defaultRunCommandOptions snapshotCounterEventStream target (Add 3) + case result of + Right (Right commandResult) -> + commandResult ^. #streamVersion `shouldBe` StreamVersion 3 + other -> expectationFailure ("expected snapshot-covered command success, got " <> show other) + + it "uses caller-supplied event ids for idempotent command batches" $ \storeHandle -> do + let target = stream "counter-command-event-id" :: Stream CounterEventStream + supplied = EventId sampleUuid2 + options = defaultRunCommandOptions & #eventIds .~ [supplied] + result <- + Store.runStoreIO storeHandle $ + runCommand options counterEventStream target (Add 7) + case result of + Right (Right commandResult) -> + commandResult ^. #streamVersion `shouldBe` StreamVersion 1 + other -> expectationFailure ("expected successful command, got " <> show other) + Right recorded <- + Store.runStoreIO storeHandle $ + Store.readStreamForward (StreamName "counter-command-event-id") (StreamVersion 0) 10 + fmap (^. #eventId) (Vector.toList recorded) `shouldBe` [supplied] + + it "retries an optimistic conflict after rehydrating the winning event" $ \storeHandle -> do + conflictInserted <- newIORef False + let target = stream "counter-command-conflict" :: Stream CounterEventStream + conflictStreamName = StreamName "counter-command-conflict" + insertConflict = do + shouldInsert <- atomicModifyIORef' conflictInserted $ \alreadyInserted -> + if alreadyInserted + then (True, False) + else (True, True) + when shouldInsert $ do + encoded <- shouldBeRight (encodeForAppend counterCodec (CounterAdded 10)) + outcome <- + Store.runStoreIO storeHandle $ + Store.appendToStream conflictStreamName NoStream [encoded] + case outcome of + Right _ -> pure () + Left err -> expectationFailure ("failed to insert conflict event: " <> show err) + options = defaultRunCommandOptions & #beforeAppend .~ insertConflict + result <- + Store.runStoreIO storeHandle $ + runCommand options counterEventStream target (Add 2) + case result of + Right (Right commandResult) -> do + commandResult ^. #streamVersion `shouldBe` StreamVersion 2 + commandResult ^. #eventsAppended `shouldBe` 1 + other -> expectationFailure ("expected retry to succeed, got " <> show other) + Right recorded <- + Store.runStoreIO storeHandle $ + Store.readStreamForward conflictStreamName (StreamVersion 0) 10 + traverse (decodeRecorded counterCodec) (Vector.toList recorded) + `shouldBe` Right [CounterAdded 10, CounterAdded 2] + + it "reports true retry attempts and command conflict metrics when the retry budget is exhausted" $ \storeHandle -> do + (exporter, metricsRef) <- inMemoryMetricExporter + (provider, _env) <- + createMeterProvider + emptyMaterializedResources + defaultSdkMeterProviderOptions {metricExporter = Just exporter} + meter <- getMeter provider Telemetry.keiroInstrumentationLibrary + keiroMetrics <- Telemetry.newKeiroMetrics meter + let target = stream "counter-command-exhausted-conflict" :: Stream CounterEventStream + conflictStreamName = StreamName "counter-command-exhausted-conflict" + insertConflict = do + encoded <- shouldBeRight (encodeForAppend counterCodec (CounterAdded 10)) + outcome <- + Store.runStoreIO storeHandle $ + Store.appendToStream conflictStreamName AnyVersion [encoded] + case outcome of + Right _ -> pure () + Left err -> expectationFailure ("failed to insert conflict event: " <> show err) + options = + defaultRunCommandOptions + & #beforeAppend + .~ insertConflict + & #retryLimit + .~ 2 + & #retryBackoffMicros + .~ 0 + & #metrics + ?~ keiroMetrics + result <- + Store.runStoreIO storeHandle $ + runCommand options counterEventStream target (Add 2) + case result of + Right (Left (RetryExhausted attempts _)) -> + attempts `shouldBe` 3 + other -> expectationFailure ("expected exhausted retry budget, got " <> show other) + _ <- forceFlushMeterProvider provider Nothing + exported <- readIORef metricsRef + let scalars = flattenScalarPoints exported + lookup "keiro.command.conflicts" scalars `shouldBe` Just (IntNumber 3) + lookup "keiro.command.retries" scalars `shouldBe` Just (IntNumber 2) + + it "records the successful retry attempt on the command span" $ \storeHandle -> do + (processor, spansRef) <- inMemoryListExporter + provider <- createTracerProvider [processor] emptyTracerProviderOptions + conflictInserted <- newIORef False + let tracer = makeTracer provider "keiro-test" tracerOptions + target = stream "counter-command-retry-span" :: Stream CounterEventStream + conflictStreamName = StreamName "counter-command-retry-span" + insertConflict = do + shouldInsert <- atomicModifyIORef' conflictInserted $ \alreadyInserted -> + if alreadyInserted + then (True, False) + else (True, True) + when shouldInsert $ do + encoded <- shouldBeRight (encodeForAppend counterCodec (CounterAdded 10)) + outcome <- + Store.runStoreIO storeHandle $ + Store.appendToStream conflictStreamName NoStream [encoded] + case outcome of + Right _ -> pure () + Left err -> expectationFailure ("failed to insert conflict event: " <> show err) + options = + defaultRunCommandOptions + & #beforeAppend + .~ insertConflict + & #retryBackoffMicros + .~ 0 + & #tracer + ?~ tracer + Right (Right _) <- + Store.runStoreIO storeHandle $ + runCommand options counterEventStream target (Add 2) + _ <- shutdownTracerProvider provider Nothing + spans <- traverse captureSpan =<< readIORef spansRef + case spans of + [sp] -> + case lookupAttribute (csAttributes sp) "keiro.retry.attempt" of + Just (AttributeValue (IntAttribute n)) -> n `shouldBe` 2 + other -> expectationFailure ("expected retry attempt attribute 2, got " <> show other) + other -> expectationFailure ("expected one span, got " <> show (length other)) + + it "counts duplicate deterministic command events" $ \storeHandle -> do + (exporter, metricsRef) <- inMemoryMetricExporter + (provider, _env) <- + createMeterProvider + emptyMaterializedResources + defaultSdkMeterProviderOptions {metricExporter = Just exporter} + meter <- getMeter provider Telemetry.keiroInstrumentationLibrary + keiroMetrics <- Telemetry.newKeiroMetrics meter + let supplied = EventId sampleUuid3 + first = stream "counter-command-duplicate-a" :: Stream CounterEventStream + second = stream "counter-command-duplicate-b" :: Stream CounterEventStream + options = + defaultRunCommandOptions + & #eventIds + .~ [supplied] + & #metrics + ?~ keiroMetrics + Right (Right _) <- + Store.runStoreIO storeHandle $ + runCommand options counterEventStream first (Add 1) + result <- + Store.runStoreIO storeHandle $ + runCommand options counterEventStream second (Add 2) + case result of + Right (Left (StoreFailed Store.DuplicateEvent {})) -> pure () + other -> expectationFailure ("expected duplicate event failure, got " <> show other) + _ <- forceFlushMeterProvider provider Nothing + exported <- readIORef metricsRef + lookup "keiro.command.duplicates" (flattenScalarPoints exported) `shouldBe` Just (IntNumber 1) + + it "fails fast when a soft-deleted stream causes a conflict fixpoint" $ \storeHandle -> do + (exporter, metricsRef) <- inMemoryMetricExporter + (provider, _env) <- + createMeterProvider + emptyMaterializedResources + defaultSdkMeterProviderOptions {metricExporter = Just exporter} + meter <- getMeter provider Telemetry.keiroInstrumentationLibrary + keiroMetrics <- Telemetry.newKeiroMetrics meter + let target = stream "counter-command-soft-deleted" :: Stream CounterEventStream + options = + defaultRunCommandOptions + & #retryBackoffMicros + .~ 0 + & #metrics + ?~ keiroMetrics + Right (Right _) <- + Store.runStoreIO storeHandle $ + runCommand options counterEventStream target (Add 1) + Right (Just _) <- + Store.runStoreIO storeHandle $ + Store.softDeleteStream (StreamName "counter-command-soft-deleted") + result <- + Store.runStoreIO storeHandle $ + runCommand options counterEventStream target (Add 2) + case result of + Right (Left (ConflictFixpoint (StreamVersion 0) Store.StreamAlreadyExists {})) -> pure () + other -> expectationFailure ("expected conflict fixpoint, got " <> show other) + _ <- forceFlushMeterProvider provider Nothing + exported <- readIORef metricsRef + lookup "keiro.command.conflicts" (flattenScalarPoints exported) `shouldBe` Just (IntNumber 1) + + it "surfaces decode failure during hydration" $ \storeHandle -> do + Right _ <- + Store.runStoreIO storeHandle $ + Store.appendToStream + (StreamName "counter-command-decode-failure") + NoStream + [ EventData + { eventId = Nothing, + eventType = EventType "OtherEvent", + payload = object [], + metadata = Just (metadataForOrDie 1 Nothing), + causationId = Nothing, + correlationId = Nothing + } + ] + let target = stream "counter-command-decode-failure" :: Stream CounterEventStream + result <- + Store.runStoreIO storeHandle $ + runCommand defaultRunCommandOptions counterEventStream target (Add 1) + result + `shouldBe` Right + (Left (HydrationDecodeFailed (UnknownEventType (EventType "OtherEvent") [EventType "CounterAdded", EventType "CounterAudited"]))) + + it "surfaces a typed no-inverting-edge hydration failure" $ \storeHandle -> do + let targetStreamName = StreamName "counter-command-no-inverting-edge" + target = stream "counter-command-no-inverting-edge" :: Stream CounterEventStream + appendCounterEvents storeHandle targetStreamName [CounterAudited 7] + result <- + Store.runStoreIO storeHandle $ + runCommand defaultRunCommandOptions counterEventStream target (Add 1) + result + `shouldBe` Right + (Left (HydrationReplayFailed (StreamVersion 1) HydrationNoInvertingEdge)) + + it "fails hydration after guard tightening without a replay-only twin (plan 143 reproduction)" $ \storeHandle -> do + let target = stream "divert-black-acuity-bad" :: Stream DivertEventStream + Right (Right appended) <- + Store.runStoreIO storeHandle $ + runCommand defaultRunCommandOptions permissiveDivertEventStream target (ConfirmDivert True) + appended ^. #streamVersion `shouldBe` StreamVersion 1 + result <- + Store.runStoreIO storeHandle $ + runCommand defaultRunCommandOptions tightenedDivertEventStream target (ConfirmDivert False) + result + `shouldBe` Right + (Left (HydrationReplayFailed (StreamVersion 1) HydrationNoInvertingEdge)) + + it "replays black-acuity history through the replay-only twin and keeps serving the live rule" $ \storeHandle -> do + let target = stream "divert-black-acuity-good" :: Stream DivertEventStream + Right (Right appended) <- + Store.runStoreIO storeHandle $ + runCommand defaultRunCommandOptions permissiveDivertEventStream target (ConfirmDivert True) + appended ^. #streamVersion `shouldBe` StreamVersion 1 + result <- + Store.runStoreIO storeHandle $ + runCommand defaultRunCommandOptions twinDivertEventStream target (ConfirmDivert False) + case result of + Right (Right commandResult) -> do + commandResult ^. #streamVersion `shouldBe` StreamVersion 2 + commandResult ^. #eventsAppended `shouldBe` 1 + other -> + expectationFailure ("expected hydration through the twin to succeed, got " <> show other) + Right recorded <- + Store.runStoreIO storeHandle $ + Store.readStreamForward (StreamName "divert-black-acuity-good") (StreamVersion 0) 10 + traverse (decodeRecorded divertCodec) (Vector.toList recorded) + `shouldBe` Right [DivertConfirmed True, DivertConfirmed False] + + it "rejects a new command in the removed region under the twin-bearing machine" $ \storeHandle -> do + let target = stream "divert-black-acuity-removed" :: Stream DivertEventStream + Right (Right _) <- + Store.runStoreIO storeHandle $ + runCommand defaultRunCommandOptions permissiveDivertEventStream target (ConfirmDivert True) + result <- + Store.runStoreIO storeHandle $ + runCommand defaultRunCommandOptions twinDivertEventStream target (ConfirmDivert True) + result `shouldBe` Right (Left CommandRejected) + Right recorded <- + Store.runStoreIO storeHandle $ + Store.readStreamForward (StreamName "divert-black-acuity-removed") (StreamVersion 0) 10 + Vector.length recorded `shouldBe` 1 + + it "surfaces a typed queue-mismatch hydration failure with the failing version" $ \storeHandle -> do + let targetStreamName = StreamName "counter-command-queue-mismatch" + target = stream "counter-command-queue-mismatch" :: Stream CounterEventStream + appendCounterEvents storeHandle targetStreamName [CounterAdded 5, CounterAudited 6] + result <- + Store.runStoreIO storeHandle $ + runCommand defaultRunCommandOptions multiCounterEventStream target (Add 1) + result + `shouldBe` Right + (Left (HydrationReplayFailed (StreamVersion 2) HydrationQueueMismatch)) + + it "surfaces a truncated multi-event chain as HydrationTruncatedChain" $ \storeHandle -> do + let targetStreamName = StreamName "counter-command-truncated-chain" + target = stream "counter-command-truncated-chain" :: Stream CounterEventStream + appendCounterEvents storeHandle targetStreamName [CounterAdded 5] + result <- + Store.runStoreIO storeHandle $ + runCommand defaultRunCommandOptions multiCounterEventStream target (Add 1) + result + `shouldBe` Right + (Left (HydrationReplayFailed (StreamVersion 1) HydrationTruncatedChain)) + + it "surfaces ambiguous inversion during hydration" $ \storeHandle -> do + let targetStreamName = StreamName "counter-command-ambiguous-inversion" + target = stream "counter-command-ambiguous-inversion" :: Stream CounterEventStream + appendCounterEvents storeHandle targetStreamName [CounterAdded 3] + result <- + Store.runStoreIO storeHandle $ + runCommand defaultRunCommandOptions inversionAmbiguousEventStream target (Add 1) + result + `shouldBe` Right + (Left (HydrationReplayFailed (StreamVersion 1) HydrationAmbiguousInversion)) + + it "truncates command span error status descriptions" $ \storeHandle -> do + (processor, spansRef) <- inMemoryListExporter + provider <- createTracerProvider [processor] emptyTracerProviderOptions + let tracer = makeTracer provider "keiro-test" tracerOptions + longTag = Text.replicate 400 "x" + Right _ <- + Store.runStoreIO storeHandle $ + Store.appendToStream + (StreamName "counter-command-long-decode-failure") + NoStream + [ EventData + { eventId = Nothing, + eventType = EventType longTag, + payload = object [], + metadata = Just (metadataForOrDie 1 Nothing), + causationId = Nothing, + correlationId = Nothing + } + ] + let target = stream "counter-command-long-decode-failure" :: Stream CounterEventStream + options = defaultRunCommandOptions & #tracer ?~ tracer + _ <- + Store.runStoreIO storeHandle $ + runCommand options counterEventStream target (Add 1) + _ <- shutdownTracerProvider provider Nothing + spans <- traverse captureSpan =<< readIORef spansRef + case spans of + [sp] -> + case csStatus sp of + Error description -> Text.length description `shouldSatisfy` (<= 256) + other -> expectationFailure ("expected error span status, got " <> show other) + other -> expectationFailure ("expected one span, got " <> show (length other)) + + it "rolls back the append when inline SQL condemns the transaction" $ \_ -> + withFreshResourceStore fixture $ \(storeHandle, StoreRunner runner) -> do + let target = stream "counter-command-rollback" :: Stream CounterEventStream + result <- + runner $ + runCommandWithSql + defaultRunCommandOptions + counterEventStream + target + (Add 1) + (\_ -> Tx.condemn >> pure ("rolled-back" :: Text)) + case result of + Right (Right (_, Just "rolled-back")) -> pure () + other -> expectationFailure ("expected condemned transaction result, got " <> show other) + Right recorded <- + Store.runStoreIO storeHandle $ + Store.readStreamForward (StreamName "counter-command-rollback") (StreamVersion 0) 10 + recorded `shouldBe` Vector.empty + + it "appends all events emitted by one accepted command" $ \storeHandle -> do + let target = stream "counter-command-multi-create" :: Stream CounterEventStream + result <- + Store.runStoreIO storeHandle $ + runCommand defaultRunCommandOptions multiCounterEventStream target (Add 5) + case result of + Right (Right commandResult) -> do + commandResult ^. #streamVersion `shouldBe` StreamVersion 2 + commandResult ^. #eventsAppended `shouldBe` 2 + commandResult ^. #globalPosition `shouldSatisfy` isJust + other -> expectationFailure ("expected successful multi-event command, got " <> show other) + Right recorded <- + Store.runStoreIO storeHandle $ + Store.readStreamForward (StreamName "counter-command-multi-create") (StreamVersion 0) 10 + traverse (decodeRecorded counterCodec) (Vector.toList recorded) + `shouldBe` Right [CounterAdded 5, CounterAudited 5] + + it "counts and traces a just-appended batch that cannot replay" $ \storeHandle -> do + (exporter, metricsRef) <- inMemoryMetricExporter + (metricProvider, _env) <- + createMeterProvider + emptyMaterializedResources + defaultSdkMeterProviderOptions {metricExporter = Just exporter} + meter <- getMeter metricProvider Telemetry.keiroInstrumentationLibrary + keiroMetrics <- Telemetry.newKeiroMetrics meter + (processor, spansRef) <- inMemoryListExporter + tracerProvider <- createTracerProvider [processor] emptyTracerProviderOptions + let tracer = makeTracer tracerProvider "keiro-test" tracerOptions + target = stream "counter-command-replay-divergence" :: Stream CounterEventStream + options = + defaultRunCommandOptions + & #metrics + ?~ keiroMetrics + & #tracer + ?~ tracer + Right (Right commandResult) <- + Store.runStoreIO storeHandle $ + runCommand options headUnrecoverableEventStream target (Add 2) + commandResult ^. #streamVersion `shouldBe` StreamVersion 2 + commandResult ^. #eventsAppended `shouldBe` 2 + _ <- forceFlushMeterProvider metricProvider Nothing + exported <- readIORef metricsRef + lookup "keiro.snapshot.apply.divergence" (flattenScalarPoints exported) + `shouldBe` Just (IntNumber 1) + next <- + Store.runStoreIO storeHandle $ + runCommand defaultRunCommandOptions headUnrecoverableEventStream target (Add 3) + case next of + Right (Left HydrationReplayFailed {}) -> pure () + other -> expectationFailure ("expected the witnessed divergence to poison hydration, got " <> show other) + _ <- shutdownTracerProvider tracerProvider Nothing + spans <- traverse captureSpan =<< readIORef spansRef + case spans of + [sp] -> + textAttr (csAttributes sp) "keiro.replay.divergence" + `shouldBe` Just "event_index=0;reason=no_inverting_edge" + other -> expectationFailure ("expected one divergence span, got " <> show (length other)) + + it "skips replay verification for a snapshot-less stream when disabled" $ \storeHandle -> do + (exporter, metricsRef) <- inMemoryMetricExporter + (provider, _env) <- + createMeterProvider + emptyMaterializedResources + defaultSdkMeterProviderOptions {metricExporter = Just exporter} + meter <- getMeter provider Telemetry.keiroInstrumentationLibrary + keiroMetrics <- Telemetry.newKeiroMetrics meter + let target = stream "counter-command-replay-divergence-disabled" :: Stream CounterEventStream + options = + defaultRunCommandOptions + & #metrics + ?~ keiroMetrics + & #verifyReplayOnAppend + .~ False + Right (Right commandResult) <- + Store.runStoreIO storeHandle $ + runCommand options headUnrecoverableEventStream target (Add 2) + commandResult ^. #eventsAppended `shouldBe` 2 + _ <- forceFlushMeterProvider provider Nothing + exported <- readIORef metricsRef + lookup "keiro.snapshot.apply.divergence" (flattenScalarPoints exported) + `shouldBe` Nothing + + it "witnesses replay divergence on the transactional SQL append path" $ \_ -> + withFreshResourceStore fixture $ \(_storeHandle, StoreRunner runner) -> do + (exporter, metricsRef) <- inMemoryMetricExporter + (provider, _env) <- + createMeterProvider + emptyMaterializedResources + defaultSdkMeterProviderOptions {metricExporter = Just exporter} + meter <- getMeter provider Telemetry.keiroInstrumentationLibrary + keiroMetrics <- Telemetry.newKeiroMetrics meter + let target = stream "counter-command-replay-divergence-sql" :: Stream CounterEventStream + options = defaultRunCommandOptions & #metrics ?~ keiroMetrics + Right (Right (commandResult, Just ())) <- + runner $ + runCommandWithSqlEvents + options + headUnrecoverableEventStream + target + (Add 2) + (\_ _ -> pure ()) + commandResult ^. #eventsAppended `shouldBe` 2 + _ <- forceFlushMeterProvider provider Nothing + exported <- readIORef metricsRef + lookup "keiro.snapshot.apply.divergence" (flattenScalarPoints exported) + `shouldBe` Just (IntNumber 1) + + it "replays a prior multi-event command before appending the next batch" $ \storeHandle -> do + let target = stream "counter-command-multi-replay" :: Stream CounterEventStream + Right (Right _) <- + Store.runStoreIO storeHandle $ + runCommand defaultRunCommandOptions multiCounterEventStream target (Add 2) + result <- + Store.runStoreIO storeHandle $ + runCommand defaultRunCommandOptions multiCounterEventStream target (Add 3) + case result of + Right (Right commandResult) -> do + commandResult ^. #streamVersion `shouldBe` StreamVersion 4 + commandResult ^. #eventsAppended `shouldBe` 2 + other -> expectationFailure ("expected successful second multi-event command, got " <> show other) + Right recorded <- + Store.runStoreIO storeHandle $ + Store.readStreamForward (StreamName "counter-command-multi-replay") (StreamVersion 0) 10 + traverse (decodeRecorded counterCodec) (Vector.toList recorded) + `shouldBe` Right [CounterAdded 2, CounterAudited 2, CounterAdded 3, CounterAudited 3] + + it "passes the complete multi-event batch to inline SQL in append order" $ \_ -> + withFreshResourceStore fixture $ \(_storeHandle, StoreRunner runner) -> do + let target = stream "counter-command-multi-sql-events" :: Stream CounterEventStream + result <- + runner $ + runCommandWithSqlEvents + defaultRunCommandOptions + multiCounterEventStream + target + (Add 8) + (\pairs _ -> pure (Prelude.map Prelude.fst pairs)) + case result of + Right (Right (commandResult, Just observed)) -> do + commandResult ^. #streamVersion `shouldBe` StreamVersion 2 + commandResult ^. #eventsAppended `shouldBe` 2 + observed `shouldBe` [CounterAdded 8, CounterAudited 8] + other -> expectationFailure ("expected successful SQL multi-event command, got " <> show other) + + it "command metadata is merged into stored event metadata" $ \storeHandle -> do + let target = stream "counter-command-metadata" :: Stream CounterEventStream + opts = + defaultRunCommandOptions + & #metadata + ?~ object ["actor" Aeson..= ("agent-7" :: Text)] + Right (Right _) <- + Store.runStoreIO storeHandle $ + runCommand opts counterEventStream target (Add 4) + Right recorded <- + Store.runStoreIO storeHandle $ + Store.readStreamForward (StreamName "counter-command-metadata") (StreamVersion 0) 10 + case Vector.toList recorded of + [event] -> + event ^. #metadata + `shouldBe` Just (object ["actor" Aeson..= ("agent-7" :: Text), "schemaVersion" Aeson..= (1 :: Int)]) + other -> expectationFailure ("expected a single recorded event, got " <> show other) + + it "reconstructed RecordedEvents match the stored batch" $ \_ -> + withFreshResourceStore fixture $ \(storeHandle, StoreRunner runner) -> do + let target = stream "counter-reconstruct-fidelity" :: Stream CounterEventStream + opts = + defaultRunCommandOptions + & #metadata + ?~ object ["actor" Aeson..= ("agent-7" :: Text)] + Right (Right (_, Just pairs)) <- + runner $ + runCommandWithSqlEvents opts multiCounterEventStream target (Add 8) (\ps _ -> pure ps) + let reconstructed = Prelude.map Prelude.snd pairs + -- Read the stored events back from their source stream. + Right storedVec <- + Store.runStoreIO storeHandle $ + Store.readStreamForward (StreamName "counter-reconstruct-fidelity") (StreamVersion 0) 10 + let stored = Vector.toList storedVec + -- readStreamForward reports globalPosition 0 for stream reads, so take + -- the true global positions from a category read (the DB is fresh per + -- test, so category "counter" holds exactly this batch). + Right catVec <- + Store.runStoreIO storeHandle $ + Store.readCategory (CategoryName "counter") (GlobalPosition 0) 10 + let catList = Vector.toList catVec + Prelude.length reconstructed `shouldBe` 2 + Prelude.length stored `shouldBe` 2 + fmap (^. #eventId) reconstructed `shouldBe` fmap (^. #eventId) stored + fmap (^. #eventType) reconstructed `shouldBe` fmap (^. #eventType) stored + fmap (^. #streamVersion) reconstructed `shouldBe` fmap (^. #streamVersion) stored + fmap (^. #originalVersion) reconstructed `shouldBe` fmap (^. #originalVersion) stored + fmap (^. #originalStreamId) reconstructed `shouldBe` fmap (^. #originalStreamId) stored + fmap (^. #payload) reconstructed `shouldBe` fmap (^. #payload) stored + fmap (^. #metadata) reconstructed `shouldBe` fmap (^. #metadata) stored + fmap (^. #globalPosition) reconstructed `shouldBe` fmap (^. #globalPosition) catList + + it "runCommand emits a Command span with the stream name, db.system.name, and keiro.events.appended" $ \storeHandle -> do + (processor, spansRef) <- inMemoryListExporter + provider <- createTracerProvider [processor] emptyTracerProviderOptions + let tracer = makeTracer provider "keiro-test" tracerOptions + target = stream "counter-command-otel" :: Stream CounterEventStream + options = defaultRunCommandOptions & #tracer ?~ tracer + Right (Right commandResult) <- + Store.runStoreIO storeHandle $ + runCommand options counterEventStream target (Add 9) + commandResult ^. #streamVersion `shouldBe` StreamVersion 1 + _ <- shutdownTracerProvider provider Nothing + spans <- traverse captureSpan =<< readIORef spansRef + length spans `shouldBe` 1 + let sp = case spans of + (s : _) -> s + [] -> error "no command span captured" + csName sp `shouldBe` "counter-command-otel" + show (csKind sp) `shouldBe` "Internal" + textAttr (csAttributes sp) "keiro.stream.name" `shouldBe` Just "counter-command-otel" + textAttr (csAttributes sp) "db.system.name" `shouldBe` Just "postgresql" + -- keiro.events.appended is an Int64 attribute, not Text. + case lookupAttribute (csAttributes sp) "keiro.events.appended" of + Just (AttributeValue (IntAttribute n)) -> n `shouldBe` 1 + other -> expectationFailure ("expected IntAttribute 1, got " <> show other) + case csStatus sp of + Unset -> pure () + Ok -> pure () + other -> expectationFailure ("expected Unset/Ok, got " <> show other) + + describe "Keiro.Command enrichment parity" $ do + let addMarker eventData = pure (eventData & #metadata %~ injectMarker) + injectMarker = \case + Just (Aeson.Object fields) -> + Just (Aeson.Object (KeyMap.insert "enriched" (Aeson.Bool True) fields)) + _ -> Just (object ["enriched" Aeson..= True]) + installHook = #storeSettings . #enrichEvent ?~ addMarker + hasMarker = \case + Just (Aeson.Object fields) -> + KeyMap.lookup "enriched" fields == Just (Aeson.Bool True) + _ -> False + around (withFreshResourceStoreWith fixture installHook) $ + it "applies the store enrichment hook to both command append paths" $ \(_storeHandle, StoreRunner runner) -> do + let plainTarget = stream "enrich-plain" :: Stream CounterEventStream + transactionalTarget = stream "enrich-transactional" :: Stream CounterEventStream + Right (Right _) <- + runner $ + runCommand defaultRunCommandOptions counterEventStream plainTarget (Add 1) + Right (Right (_, Just callbackRecordeds)) <- + runner $ + runCommandWithSqlEvents + defaultRunCommandOptions + counterEventStream + transactionalTarget + (Add 1) + (\pairs _ -> pure (fmap snd pairs)) + Right plainEvents <- + runner $ + Store.readStreamForward (StreamName "enrich-plain") (StreamVersion 0) 10 + Right transactionalEvents <- + runner $ + Store.readStreamForward (StreamName "enrich-transactional") (StreamVersion 0) 10 + for_ (Vector.toList plainEvents <> Vector.toList transactionalEvents) $ \recorded -> + recorded ^. #metadata `shouldSatisfy` hasMarker + for_ callbackRecordeds $ \recorded -> + recorded ^. #metadata `shouldSatisfy` hasMarker + + describe "Keiro.Snapshot" $ around (withFreshStore fixture) $ do + it "reports an ErrorCall when strict encoding reaches an empty register slot" $ \_storeHandle -> do + result <- + encodeSnapshotStrict + (defaultStateCodec @SnapshotCounterRegs @CounterState 1) + (Counting, emptyRegFile @SnapshotCounterRegs) + case result of + Left err -> displayException err `shouldSatisfy` isInfixOf "uninit: lastAmount" + Right _ -> expectationFailure "expected strict snapshot encoding to fail on an empty register slot" + + it "writes a snapshot after policy threshold" $ \storeHandle -> do + let target = stream "snapshot-write-threshold" :: Stream SnapshotCounterEventStream + Right (Right _) <- + Store.runStoreIO storeHandle $ + runCommand defaultRunCommandOptions snapshotCounterEventStream target (Add 2) + Right (Right _) <- + Store.runStoreIO storeHandle $ + runCommand defaultRunCommandOptions snapshotCounterEventStream target (Add 3) + Right snapshotVersion <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + Tx.statement "snapshot-write-threshold" snapshotVersionForStreamStmt + snapshotVersion `shouldBe` Just (StreamVersion 2) + + it "does not fail a committed command when the post-commit snapshot write fails" $ \storeHandle -> do + (exporter, metricsRef) <- inMemoryMetricExporter + (provider, _env) <- + createMeterProvider + emptyMaterializedResources + defaultSdkMeterProviderOptions {metricExporter = Just exporter} + meter <- getMeter provider Telemetry.keiroInstrumentationLibrary + keiroMetrics <- Telemetry.newKeiroMetrics meter + let target = stream "snapshot-write-failure-swallowed" :: Stream SnapshotCounterEventStream + options = defaultRunCommandOptions & #metrics ?~ keiroMetrics + Right (Right _) <- + Store.runStoreIO storeHandle $ + runCommand options snapshotCounterEventStream target (Add 2) + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + Tx.sql "ALTER TABLE keiro.keiro_snapshots ADD CONSTRAINT keiro_snapshots_no_writes CHECK (false) NOT VALID" + result <- + Store.runStoreIO storeHandle $ + runCommand options snapshotCounterEventStream target (Add 3) + case result of + Right (Right commandResult) -> do + commandResult ^. #streamVersion `shouldBe` StreamVersion 2 + commandResult ^. #eventsAppended `shouldBe` 1 + other -> expectationFailure ("expected committed command despite snapshot failure, got " <> show other) + Right recorded <- + Store.runStoreIO storeHandle $ + Store.readStreamForward (StreamName "snapshot-write-failure-swallowed") (StreamVersion 0) 10 + traverse (decodeRecorded counterCodec) (Vector.toList recorded) + `shouldBe` Right [CounterAdded 2, CounterAdded 3] + Right snapshotVersionDuringFailure <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + Tx.statement "snapshot-write-failure-swallowed" snapshotVersionForStreamStmt + snapshotVersionDuringFailure `shouldBe` Nothing + _ <- forceFlushMeterProvider provider Nothing + exported <- readIORef metricsRef + lookup "keiro.snapshot.write.failures" (flattenScalarPoints exported) `shouldBe` Just (IntNumber 1) + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + Tx.sql "ALTER TABLE keiro.keiro_snapshots DROP CONSTRAINT keiro_snapshots_no_writes" + Right (Right _) <- + Store.runStoreIO storeHandle $ + runCommand options snapshotCounterEventStream target (Add 4) + Right (Right _) <- + Store.runStoreIO storeHandle $ + runCommand options snapshotCounterEventStream target (Add 5) + Right snapshotVersionAfterRecovery <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + Tx.statement "snapshot-write-failure-swallowed" snapshotVersionForStreamStmt + snapshotVersionAfterRecovery `shouldBe` Just (StreamVersion 4) + + it "does not fail a committed command when strict snapshot encoding fails" $ \storeHandle -> do + (exporter, metricsRef) <- inMemoryMetricExporter + (provider, _env) <- + createMeterProvider + emptyMaterializedResources + defaultSdkMeterProviderOptions {metricExporter = Just exporter} + meter <- getMeter provider Telemetry.keiroInstrumentationLibrary + keiroMetrics <- Telemetry.newKeiroMetrics meter + let target = stream "snapshot-encode-failure-swallowed" :: Stream PartialSnapshotEventStream + options = defaultRunCommandOptions & #metrics ?~ keiroMetrics + result <- + Store.runStoreIO storeHandle $ + runCommand options partialSnapshotEventStream target (Add 7) + case result of + Right (Right commandResult) -> do + commandResult ^. #streamVersion `shouldBe` StreamVersion 1 + commandResult ^. #eventsAppended `shouldBe` 1 + other -> expectationFailure ("expected committed command despite snapshot encode failure, got " <> show other) + Right recorded <- + Store.runStoreIO storeHandle $ + Store.readStreamForward (StreamName "snapshot-encode-failure-swallowed") (StreamVersion 0) 10 + traverse (decodeRecorded counterCodec) (Vector.toList recorded) + `shouldBe` Right [CounterAdded 7] + Right snapshotVersion <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + Tx.statement "snapshot-encode-failure-swallowed" snapshotVersionForStreamStmt + snapshotVersion `shouldBe` Nothing + _ <- forceFlushMeterProvider provider Nothing + exported <- readIORef metricsRef + let scalars = flattenScalarPoints exported + lookup "keiro.snapshot.encode.failures" scalars `shouldBe` Just (IntNumber 1) + lookup "keiro.snapshot.write.failures" scalars `shouldBe` Nothing + + it "hydrates from snapshot and replays only the tail" $ \storeHandle -> do + (exporter, metricsRef) <- inMemoryMetricExporter + (provider, _env) <- + createMeterProvider + emptyMaterializedResources + defaultSdkMeterProviderOptions {metricExporter = Just exporter} + meter <- getMeter provider Telemetry.keiroInstrumentationLibrary + keiroMetrics <- Telemetry.newKeiroMetrics meter + let target = stream "snapshot-tail-hydration" :: Stream SnapshotCounterEventStream + options = defaultRunCommandOptions & #metrics ?~ keiroMetrics + Right (Right _) <- + Store.runStoreIO storeHandle $ + runCommand options snapshotCounterEventStream target (Add 2) + Right (Right _) <- + Store.runStoreIO storeHandle $ + runCommand options snapshotCounterEventStream target (Add 3) + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + Tx.statement + ( "snapshot-tail-hydration", + (defaultStateCodec @SnapshotCounterRegs @CounterState 1 ^. #encode) + (Counting, RCons (Proxy @"lastAmount") 4 RNil) + ) + corruptSnapshotStateStmt + result <- + Store.runStoreIO storeHandle $ + runCommand options guardedSnapshotCounterEventStream target (Add 4) + case result of + Right (Right commandResult) -> + commandResult ^. #streamVersion `shouldBe` StreamVersion 3 + other -> expectationFailure ("expected snapshot-assisted command, got " <> show other) + _ <- forceFlushMeterProvider provider Nothing + exported <- readIORef metricsRef + lookup "keiro.snapshot.read.hits" (flattenScalarPoints exported) `shouldBe` Just (IntNumber 1) + + it "falls back when snapshot JSON is corrupt" $ \storeHandle -> do + (exporter, metricsRef) <- inMemoryMetricExporter + (provider, _env) <- + createMeterProvider + emptyMaterializedResources + defaultSdkMeterProviderOptions {metricExporter = Just exporter} + meter <- getMeter provider Telemetry.keiroInstrumentationLibrary + keiroMetrics <- Telemetry.newKeiroMetrics meter + let target = stream "snapshot-corrupt-json" :: Stream SnapshotCounterEventStream + options = defaultRunCommandOptions & #metrics ?~ keiroMetrics + Right (Right _) <- + Store.runStoreIO storeHandle $ + runCommand options snapshotCounterEventStream target (Add 2) + Right (Right _) <- + Store.runStoreIO storeHandle $ + runCommand options snapshotCounterEventStream target (Add 3) + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + Tx.statement ("snapshot-corrupt-json", Aeson.String "bad") corruptSnapshotStateStmt + result <- + Store.runStoreIO storeHandle $ + runCommand options snapshotCounterEventStream target (Add 4) + case result of + Right (Right commandResult) -> + commandResult ^. #streamVersion `shouldBe` StreamVersion 3 + other -> expectationFailure ("expected corrupt snapshot fallback, got " <> show other) + _ <- forceFlushMeterProvider provider Nothing + exported <- readIORef metricsRef + let scalars = flattenScalarPoints exported + lookup "keiro.snapshot.decode.failures" scalars `shouldBe` Just (IntNumber 1) + lookup "keiro.snapshot.read.misses" scalars `shouldBe` Just (IntNumber 3) + + it "falls back when shape hash mismatches" $ \storeHandle -> do + (exporter, metricsRef) <- inMemoryMetricExporter + (provider, _env) <- + createMeterProvider + emptyMaterializedResources + defaultSdkMeterProviderOptions {metricExporter = Just exporter} + meter <- getMeter provider Telemetry.keiroInstrumentationLibrary + keiroMetrics <- Telemetry.newKeiroMetrics meter + let target = stream "snapshot-shape-mismatch" :: Stream SnapshotCounterEventStream + options = defaultRunCommandOptions & #metrics ?~ keiroMetrics + Right (Right _) <- + Store.runStoreIO storeHandle $ + runCommand options snapshotCounterEventStream target (Add 2) + Right (Right _) <- + Store.runStoreIO storeHandle $ + runCommand options snapshotCounterEventStream target (Add 3) + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + Tx.statement ("snapshot-shape-mismatch", "stale-shape") corruptSnapshotShapeStmt + result <- + Store.runStoreIO storeHandle $ + runCommand options snapshotCounterEventStream target (Add 4) + case result of + Right (Right commandResult) -> + commandResult ^. #streamVersion `shouldBe` StreamVersion 3 + other -> expectationFailure ("expected stale shape fallback, got " <> show other) + _ <- forceFlushMeterProvider provider Nothing + exported <- readIORef metricsRef + let scalars = flattenScalarPoints exported + lookup "keiro.snapshot.read.misses" scalars `shouldBe` Just (IntNumber 3) + lookup "keiro.snapshot.decode.failures" scalars `shouldBe` Nothing + + it "invalidates a snapshot when the control-state shape changes" $ \storeHandle -> do + let targetStreamName = StreamName "snapshot-state-shape-change" + target = stream "snapshot-state-shape-change" :: Stream SnapshotCounterEventStream + Right (Right _) <- + Store.runStoreIO storeHandle $ + runCommand defaultRunCommandOptions snapshotCounterEventStream target (Add 2) + Right (Right _) <- + Store.runStoreIO storeHandle $ + runCommand defaultRunCommandOptions snapshotCounterEventStream target (Add 3) + lookupResult <- + Store.runStoreIO storeHandle $ + lookupSnapshotSeed + targetStreamName + (defaultStateCodec @SnapshotCounterRegs @CounterStateV2 1) + case lookupResult of + Right (SnapshotUnavailable SnapshotNotFound) -> pure () + _ -> expectationFailure "expected the changed control-state shape to miss the stored snapshot" + + it "uses the fold fingerprint as a snapshot discriminator" $ \storeHandle -> do + let targetStreamName = StreamName "snapshot-fold-fingerprint-lookup" + target = stream "snapshot-fold-fingerprint-lookup" :: Stream SnapshotCounterEventStream + foldV1Codec = + defaultStateCodecWithFold + @SnapshotCounterRegs + @CounterState + (FoldVersion "fold-v1") + 1 + foldV2Codec = + defaultStateCodecWithFold + @SnapshotCounterRegs + @CounterState + (FoldVersion "fold-v2") + 1 + Right (Right _) <- + Store.runStoreIO storeHandle $ + runCommand defaultRunCommandOptions foldV1SnapshotCounterEventStream target (Add 2) + Right (Right _) <- + Store.runStoreIO storeHandle $ + runCommand defaultRunCommandOptions foldV1SnapshotCounterEventStream target (Add 3) + sameFingerprint <- Store.runStoreIO storeHandle $ lookupSnapshotSeed targetStreamName foldV1Codec + case sameFingerprint of + Right (SnapshotHit seed) -> seed ^. #streamVersion `shouldBe` StreamVersion 2 + _ -> expectationFailure "expected an equal fold fingerprint to reuse the snapshot" + changedFingerprint <- Store.runStoreIO storeHandle $ lookupSnapshotSeed targetStreamName foldV2Codec + case changedFingerprint of + Right (SnapshotUnavailable SnapshotNotFound) -> pure () + _ -> expectationFailure "expected a changed fold fingerprint to miss the snapshot" + + it "composes the hand-owned fold version into the state discriminator" $ \_storeHandle -> do + let plain = defaultStateCodec @SnapshotCounterRegs @CounterState 1 + withFold = + defaultStateCodecWithFold + @SnapshotCounterRegs + @CounterState + (FoldVersion "fold-v1") + 1 + withFold ^. #stateShapeHash `shouldBe` (plain ^. #stateShapeHash <> ";fold=fold-v1") + withFold ^. #stateCodecVersion `shouldBe` plain ^. #stateCodecVersion + withFold ^. #shapeHash `shouldBe` plain ^. #shapeHash + + it "full-replays under a changed fold and persists the new discriminator" $ \storeHandle -> do + let targetStreamName = "snapshot-fold-fingerprint-e2e" + target = stream targetStreamName :: Stream SnapshotCounterEventStream + candidateCodec = + defaultStateCodecWithFold + @SnapshotCounterRegs + @CounterState + (FoldVersion "fold-v2") + 1 + Right (Right _) <- + Store.runStoreIO storeHandle $ + runCommand defaultRunCommandOptions foldV1SnapshotCounterEventStream target (Add 2) + Right (Right _) <- + Store.runStoreIO storeHandle $ + runCommand defaultRunCommandOptions foldV1SnapshotCounterEventStream target (Add 3) + case Keiki.applyEventsEither + foldV2SnapshotCounterTransducer + (Counting, RCons (Proxy @"lastAmount") 0 RNil) + [CounterAdded 2, CounterAdded 3] of + Right (_, RCons _ fullReplayLastAmount RNil) -> + fullReplayLastAmount `shouldBe` 4 + Left failure -> + expectationFailure ("expected full replay under fold v2, got " <> show failure) + candidateResult <- + Store.runStoreIO storeHandle $ + runCommand defaultRunCommandOptions foldV2SnapshotCounterEventStream target (Add 104) + case candidateResult of + Right (Right result) -> do + result ^. #streamVersion `shouldBe` StreamVersion 3 + result ^. #eventsAppended `shouldBe` 1 + other -> expectationFailure ("expected changed-fold full replay to accept probe command, got " <> show other) + Right storedStateShape <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + Tx.statement targetStreamName snapshotStateShapeForStreamStmt + storedStateShape `shouldBe` Just (candidateCodec ^. #stateShapeHash) + + it "pins the manual-contract hazard when fold logic changes without a discriminator bump" $ \storeHandle -> do + let targetStreamName = StreamName "snapshot-fold-manual-contract" + target = stream "snapshot-fold-manual-contract" :: Stream SnapshotCounterEventStream + unchangedCodec = + defaultStateCodecWithFold + @SnapshotCounterRegs + @CounterState + (FoldVersion "fold-v1") + 1 + Right (Right _) <- + Store.runStoreIO storeHandle $ + runCommand defaultRunCommandOptions foldV1SnapshotCounterEventStream target (Add 2) + Right (Right _) <- + Store.runStoreIO storeHandle $ + runCommand defaultRunCommandOptions foldV1SnapshotCounterEventStream target (Add 3) + staleSeed <- Store.runStoreIO storeHandle $ lookupSnapshotSeed targetStreamName unchangedCodec + case staleSeed of + Right (SnapshotHit seed) -> + case seed ^. #registers of + RCons _ staleLastAmount RNil -> staleLastAmount `shouldBe` 3 + _ -> expectationFailure "expected the unchanged discriminator to serve the stale seed" + residualResult <- + Store.runStoreIO storeHandle $ + runCommand defaultRunCommandOptions foldV2WithoutFingerprintBumpEventStream target (Add 104) + residualResult `shouldBe` Right (Left CommandRejected) + + it "samples a stale accepted seed without failing the command or writing a snapshot" $ \storeHandle -> do + (exporter, metricsRef) <- inMemoryMetricExporter + (provider, _env) <- + createMeterProvider + emptyMaterializedResources + defaultSdkMeterProviderOptions {metricExporter = Just exporter} + meter <- getMeter provider Telemetry.keiroInstrumentationLibrary + keiroMetrics <- Telemetry.newKeiroMetrics meter + let targetName = "snapshot-seed-sampled-divergence" + target = stream targetName :: Stream SnapshotCounterEventStream + candidateStream :: ValidatedSnapshotCounterEventStream + candidateStream = + mkEventStreamOrThrow + "snapshot-counter-fold-v2-sampled" + (foldV2WithoutFingerprintBumpEventStreamDef & #snapshotPolicy .~ Never) + options = + defaultRunCommandOptions + & #metrics + ?~ keiroMetrics + & #seedVerifySampleRate + .~ 1 + Right (Right _) <- + Store.runStoreIO storeHandle $ + runCommand defaultRunCommandOptions foldV1SnapshotCounterEventStream target (Add 2) + Right (Right _) <- + Store.runStoreIO storeHandle $ + runCommand defaultRunCommandOptions foldV1SnapshotCounterEventStream target (Add 3) + result <- + Store.runStoreIO storeHandle $ + runCommand options candidateStream target (Add 4) + case result of + Right (Right commandResult) -> do + commandResult ^. #streamVersion `shouldBe` StreamVersion 3 + commandResult ^. #eventsAppended `shouldBe` 1 + other -> expectationFailure ("expected sampled verification to stay advisory, got " <> show other) + observed <- + timeout 5_000_000 $ + let awaitDivergence = do + _ <- forceFlushMeterProvider provider Nothing + exported <- readIORef metricsRef + case lookup "keiro.snapshot.seed.divergence" (flattenScalarPoints exported) of + Just (IntNumber 1) -> pure () + _ -> threadDelay 10_000 >> awaitDivergence + in awaitDivergence + observed `shouldBe` Just () + Right snapshotVersion <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + Tx.statement targetName snapshotVersionForStreamStmt + snapshotVersion `shouldBe` Just (StreamVersion 2) + + it "disables sampled seed verification at rate zero" $ \storeHandle -> do + (exporter, metricsRef) <- inMemoryMetricExporter + (provider, _env) <- + createMeterProvider + emptyMaterializedResources + defaultSdkMeterProviderOptions {metricExporter = Just exporter} + meter <- getMeter provider Telemetry.keiroInstrumentationLibrary + keiroMetrics <- Telemetry.newKeiroMetrics meter + let targetName = "snapshot-seed-sampling-disabled" + target = stream targetName :: Stream SnapshotCounterEventStream + candidateStream :: ValidatedSnapshotCounterEventStream + candidateStream = + mkEventStreamOrThrow + "snapshot-counter-fold-v2-sampling-disabled" + (foldV2WithoutFingerprintBumpEventStreamDef & #snapshotPolicy .~ Never) + options = + defaultRunCommandOptions + & #metrics + ?~ keiroMetrics + & #seedVerifySampleRate + .~ 0 + Right (Right _) <- + Store.runStoreIO storeHandle $ + runCommand defaultRunCommandOptions foldV1SnapshotCounterEventStream target (Add 2) + Right (Right _) <- + Store.runStoreIO storeHandle $ + runCommand defaultRunCommandOptions foldV1SnapshotCounterEventStream target (Add 3) + Right (Right commandResult) <- + Store.runStoreIO storeHandle $ + runCommand options candidateStream target (Add 4) + commandResult ^. #streamVersion `shouldBe` StreamVersion 3 + threadDelay 100_000 + _ <- forceFlushMeterProvider provider Nothing + exported <- readIORef metricsRef + lookup "keiro.snapshot.seed.divergence" (flattenScalarPoints exported) `shouldBe` Nothing + Right snapshotVersion <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + Tx.statement targetName snapshotVersionForStreamStmt + snapshotVersion `shouldBe` Just (StreamVersion 2) + + it "falls back after operator truncation" $ \storeHandle -> do + (exporter, metricsRef) <- inMemoryMetricExporter + (provider, _env) <- + createMeterProvider + emptyMaterializedResources + defaultSdkMeterProviderOptions {metricExporter = Just exporter} + meter <- getMeter provider Telemetry.keiroInstrumentationLibrary + keiroMetrics <- Telemetry.newKeiroMetrics meter + let target = stream "snapshot-operator-truncate" :: Stream SnapshotCounterEventStream + options = defaultRunCommandOptions & #metrics ?~ keiroMetrics + Right (Right _) <- + Store.runStoreIO storeHandle $ + runCommand options snapshotCounterEventStream target (Add 2) + Right (Right _) <- + Store.runStoreIO storeHandle $ + runCommand options snapshotCounterEventStream target (Add 3) + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + Tx.sql "TRUNCATE keiro.keiro_snapshots" + result <- + Store.runStoreIO storeHandle $ + runCommand options snapshotCounterEventStream target (Add 4) + case result of + Right (Right commandResult) -> + commandResult ^. #streamVersion `shouldBe` StreamVersion 3 + other -> expectationFailure ("expected truncation fallback, got " <> show other) + _ <- forceFlushMeterProvider provider Nothing + exported <- readIORef metricsRef + let scalars = flattenScalarPoints exported + lookup "keiro.snapshot.read.misses" scalars `shouldBe` Just (IntNumber 3) + lookup "keiro.snapshot.decode.failures" scalars `shouldBe` Nothing + + it "writes snapshots after applying a complete multi-event command batch" $ \storeHandle -> do + let target = stream "snapshot-multi-event-batch" :: Stream SnapshotCounterEventStream + result <- + Store.runStoreIO storeHandle $ + runCommand defaultRunCommandOptions multiSnapshotCounterEventStream target (Add 9) + case result of + Right (Right commandResult) -> do + commandResult ^. #streamVersion `shouldBe` StreamVersion 2 + commandResult ^. #eventsAppended `shouldBe` 2 + other -> expectationFailure ("expected multi-event snapshot command, got " <> show other) + Right snapshotVersion <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + Tx.statement "snapshot-multi-event-batch" snapshotVersionForStreamStmt + snapshotVersion `shouldBe` Just (StreamVersion 2) + + it "writes a snapshot when a multi-event append crosses an Every boundary" $ \storeHandle -> do + let target = stream "snapshot-multi-event-crosses-boundary" :: Stream SnapshotCounterEventStream + boundaryEventStream :: SnapshotCounterEventStream + boundaryEventStream = + snapshotCounterEventStreamDef + & #transducer + .~ multiSnapshotCounterTransducer + & #snapshotPolicy + .~ Every 3 + validatedBoundaryEventStream = mkEventStreamOrThrow "snapshot-multi-event-crosses-boundary" boundaryEventStream + Right (Right _) <- + Store.runStoreIO storeHandle $ + runCommand defaultRunCommandOptions validatedBoundaryEventStream target (Add 2) + Right firstSnapshotVersion <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + Tx.statement "snapshot-multi-event-crosses-boundary" snapshotVersionForStreamStmt + firstSnapshotVersion `shouldBe` Nothing + result <- + Store.runStoreIO storeHandle $ + runCommand defaultRunCommandOptions validatedBoundaryEventStream target (Add 3) + case result of + Right (Right commandResult) -> + commandResult ^. #streamVersion `shouldBe` StreamVersion 4 + other -> expectationFailure ("expected successful boundary-crossing command, got " <> show other) + Right snapshotVersion <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + Tx.statement "snapshot-multi-event-crosses-boundary" snapshotVersionForStreamStmt + snapshotVersion `shouldBe` Just (StreamVersion 4) + + it "allows an incompatible snapshot codec to replace a higher-version row" $ \storeHandle -> do + let target = stream "snapshot-codec-rollback-overwrite" :: Stream SnapshotCounterEventStream + Right (Right _) <- + Store.runStoreIO storeHandle $ + runCommand defaultRunCommandOptions snapshotCounterEventStream target (Add 1) + Right (Right _) <- + Store.runStoreIO storeHandle $ + runCommand defaultRunCommandOptions snapshotCounterEventStream target (Add 2) + Right (Right _) <- + Store.runStoreIO storeHandle $ + runCommand defaultRunCommandOptions snapshotCounterEventStream target (Add 3) + Right (Right _) <- + Store.runStoreIO storeHandle $ + runCommand defaultRunCommandOptions snapshotCounterEventStream target (Add 4) + Right snapshotVersionBefore <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + Tx.statement "snapshot-codec-rollback-overwrite" snapshotVersionForStreamStmt + snapshotVersionBefore `shouldBe` Just (StreamVersion 4) + let rollbackCodec = defaultStateCodec @SnapshotCounterRegs @CounterState 2 + streamId <- + Store.runStoreIO storeHandle (Store.lookupStreamId (StreamName "snapshot-codec-rollback-overwrite")) >>= \case + Right (Just sid) -> pure sid + other -> expectationFailure ("expected stream id, got " <> show other) *> error "unreachable" + Right () <- + Store.runStoreIO storeHandle $ + writeSnapshotRow + SnapshotWrite + { streamId = streamId, + streamVersion = StreamVersion 2, + state = (rollbackCodec ^. #encode) (Counting, RCons (Proxy @"lastAmount") 2 RNil), + stateCodecVersion = rollbackCodec ^. #stateCodecVersion, + regfileShapeHash = rollbackCodec ^. #shapeHash, + stateShapeHash = rollbackCodec ^. #stateShapeHash + } + Right snapshotVersionAfter <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + Tx.statement "snapshot-codec-rollback-overwrite" snapshotVersionForStreamStmt + snapshotVersionAfter `shouldBe` Just (StreamVersion 2) + + describe "Keiro.ReplayAudit" $ around (withFreshStore fixture) $ do + it "accepts only stream names in the configured category" $ \_ -> do + ReplayAudit.streamInCategory "counter" (StreamName "counter-one") + `shouldBe` (Just (Stream.Stream (StreamName "counter-one")) :: Maybe (Stream ())) + ReplayAudit.streamInCategory "counter" (StreamName "other-one") + `shouldBe` (Nothing :: Maybe (Stream ())) + + it "catches a removed inverting edge while skipping unaffected streams" $ \storeHandle -> do + let affectedTarget = + stream "auditremove-affected" :: Stream CounterEventStream + unaffectedTarget = + stream "auditremove-unaffected" :: Stream CounterEventStream + affected = + ReplayAudit.AffectedSet + { affectedEventTypes = Set.singleton (EventType "CounterAdded"), + includeSnapshotStreams = False + } + budget = ReplayAudit.defaultAuditBudget & #parallelism .~ 2 + candidateTarget = + ReplayAudit.AuditTarget + { eventStream = auditedCounterEventStream, + category = "auditremove", + mkStream = Just . Stream.Stream + } + deployedTarget = + ReplayAudit.AuditTarget + { eventStream = counterEventStream, + category = "auditremove", + mkStream = Just . Stream.Stream + } + Right (Right _) <- + Store.runStoreIO storeHandle $ + runCommand defaultRunCommandOptions counterEventStream affectedTarget (Add 7) + Right (Right _) <- + Store.runStoreIO storeHandle $ + runCommand defaultRunCommandOptions auditedCounterEventStream unaffectedTarget (Add 9) + + Right candidateReport <- + Store.runStoreIO storeHandle $ + ReplayAudit.auditStreams + (ReplayAudit.AuditTargeted affected) + budget + candidateTarget + candidateReport ^. #streamsSelected `shouldBe` 1 + candidateReport ^. #streamsSkipped `shouldBe` 1 + candidateReport ^. #failures `shouldBe` 1 + candidateReport ^. #divergences `shouldBe` 0 + candidateReport ^. #rejectedStreams `shouldBe` [] + case candidateReport ^. #results of + [ ReplayAudit.StreamAuditResult + _ + ( ReplayAudit.ReplayFailed + (HydrationReplayFailed _ HydrationNoInvertingEdge) + ) + ] -> pure () + other -> + expectationFailure + ("expected a no-inverting-edge audit failure, got " <> show other) + + Right deployedReport <- + Store.runStoreIO storeHandle $ + ReplayAudit.auditStreams + (ReplayAudit.AuditTargeted affected) + budget + deployedTarget + ReplayAudit.auditExitCode [deployedReport] `shouldBe` 0 + + Right eventsAfterAudit <- + Store.runStoreIO storeHandle $ + Store.readStreamForward + (StreamName "auditremove-affected") + (StreamVersion 0) + 10 + Vector.length eventsAfterAudit `shouldBe` 1 + + it "proves a replay-only twin preserves the stored guard-tightening history" $ \storeHandle -> do + let target = stream "divert-audit-replay-only" :: Stream DivertEventStream + affected = + ReplayAudit.AffectedSet + { affectedEventTypes = Set.singleton (EventType "DivertConfirmed"), + includeSnapshotStreams = False + } + budget = ReplayAudit.defaultAuditBudget & #parallelism .~ 1 + auditWith candidate = + ReplayAudit.auditStreams + (ReplayAudit.AuditTargeted affected) + budget + ReplayAudit.AuditTarget + { eventStream = candidate, + category = "divert", + mkStream = Just . Stream.Stream + } + Right (Right _) <- + Store.runStoreIO storeHandle $ + runCommand defaultRunCommandOptions permissiveDivertEventStream target (ConfirmDivert True) + + Right withoutTwin <- + Store.runStoreIO storeHandle $ + auditWith tightenedDivertEventStream + withoutTwin ^. #results + `shouldBe` [ ReplayAudit.StreamAuditResult + (StreamName "divert-audit-replay-only") + ( ReplayAudit.ReplayFailed + (HydrationReplayFailed (StreamVersion 1) HydrationNoInvertingEdge) + ) + ] + ReplayAudit.auditExitCode [withoutTwin] `shouldBe` 1 + + Right withTwin <- + Store.runStoreIO storeHandle $ + auditWith twinDivertEventStream + withTwin ^. #results + `shouldBe` [ ReplayAudit.StreamAuditResult + (StreamName "divert-audit-replay-only") + ReplayAudit.ReplayOk + { ReplayAudit.streamVersion = StreamVersion 1, + ReplayAudit.digest = Nothing + } + ] + ReplayAudit.auditExitCode [withTwin] `shouldBe` 0 + + it "reports a stale accepted snapshot seed as a divergence" $ \storeHandle -> do + let target = + stream "auditfold-stale" :: Stream SnapshotCounterEventStream + auditTarget = + ReplayAudit.AuditTarget + { eventStream = foldV2WithoutFingerprintBumpEventStream, + category = "auditfold", + mkStream = Just . Stream.Stream + } + Right (Right _) <- + Store.runStoreIO storeHandle $ + runCommand defaultRunCommandOptions foldV1SnapshotCounterEventStream target (Add 7) + Right (Right _) <- + Store.runStoreIO storeHandle $ + runCommand defaultRunCommandOptions foldV1SnapshotCounterEventStream target (Add 8) + + Right outcome <- + Store.runStoreIO storeHandle $ + ReplayAudit.auditStream auditTarget target + case outcome of + ReplayAudit.SeedDivergence + { seedVersion = StreamVersion 2, + seededDigest, + fullDigest + } -> + seededDigest `shouldNotBe` fullDigest + other -> + expectationFailure + ("expected a stale-seed divergence, got " <> show other) + + it "keeps clean digests stable and resumes without re-auditing" $ \storeHandle -> do + let targets = + [ stream "auditclean-one" :: Stream SnapshotCounterEventStream, + stream "auditclean-two" :: Stream SnapshotCounterEventStream + ] + affected = + ReplayAudit.AffectedSet + { affectedEventTypes = Set.singleton (EventType "CounterAdded"), + includeSnapshotStreams = False + } + auditTarget = + ReplayAudit.AuditTarget + { eventStream = snapshotCounterEventStream, + category = "auditclean", + mkStream = Just . Stream.Stream + } + unbounded = ReplayAudit.defaultAuditBudget & #parallelism .~ 2 + for_ (zip targets [10, 20]) $ \(target, amount) -> do + Right (Right _) <- + Store.runStoreIO storeHandle $ + runCommand defaultRunCommandOptions snapshotCounterEventStream target (Add amount) + Right (Right _) <- + Store.runStoreIO storeHandle $ + runCommand defaultRunCommandOptions snapshotCounterEventStream target (Add (amount + 1)) + pure () + + Right firstFull <- + Store.runStoreIO storeHandle $ + ReplayAudit.auditStreams ReplayAudit.AuditFull unbounded auditTarget + Right secondFull <- + Store.runStoreIO storeHandle $ + ReplayAudit.auditStreams ReplayAudit.AuditFull unbounded auditTarget + firstFull ^. #streamsSelected `shouldBe` 2 + firstFull ^. #streamsSkipped `shouldBe` 0 + firstFull ^. #results `shouldBe` secondFull ^. #results + + Right firstPage <- + Store.runStoreIO storeHandle $ + ReplayAudit.auditStreams + (ReplayAudit.AuditTargeted affected) + (unbounded & #maxStreams ?~ 1) + auditTarget + firstPage ^. #streamsSelected `shouldBe` 1 + firstPage ^. #checkpoint `shouldSatisfy` isJust + Right secondPage <- + Store.runStoreIO storeHandle $ + ReplayAudit.auditStreams + (ReplayAudit.AuditTargeted affected) + ( unbounded + & #maxStreams + ?~ 1 + & #resumeFrom + .~ (firstPage ^. #checkpoint) + ) + auditTarget + secondPage ^. #streamsSelected `shouldBe` 1 + let firstNames = Set.fromList ((^. #streamName) <$> firstPage ^. #results) + secondNames = Set.fromList ((^. #streamName) <$> secondPage ^. #results) + Set.disjoint firstNames secondNames `shouldBe` True + firstNames <> secondNames + `shouldBe` Set.fromList (Stream.streamName <$> targets) + + Right targeted <- + Store.runStoreIO storeHandle $ + ReplayAudit.auditStreams + (ReplayAudit.AuditTargeted affected) + unbounded + auditTarget + targeted ^. #results `shouldBe` firstFull ^. #results + + describe "Keiro.Connection projection schema" $ + around (withFreshResourceStoreWith fixture (withProjectionSchema "app_reads")) $ do + it "places a read-model table in a configured schema, separate from keiro metadata" $ \(storeHandle, StoreRunner runner) -> do + -- qualifiedTableName builds the app's fully-qualified data table ref. + qualifiedTableName placedReadModel `shouldBe` "\"app_reads\".\"placed_counter\"" + + -- Create the app schema (opt-in) and the qualified read-model table. + Right () <- + Store.runStoreIO storeHandle $ do + ensureProjectionSchema "app_reads" + initializeRegisteredReadModel placedReadModel initializePlacedTable + + -- Drive a command with the inline projection that writes the app table. + let target = stream "placed-in-app-reads" :: Stream CounterEventStream + result <- + runner $ + runCommandWithProjections + defaultRunCommandOptions + counterEventStream + target + (Add 7) + [placedInlineProjection] + case result of + Right (Right _) -> pure () + other -> expectationFailure ("expected placed inline projection command, got " <> show other) + + -- Read it back through the configured-schema read model. + queryResult <- + Store.runStoreIO storeHandle $ + runQuery Nothing placedReadModel "placed" + queryResult `shouldBe` Right (Right 7) + + -- Prove placement: the app table is in app_reads, NOT in kiroku, and + -- Keiro's own metadata (keiro_read_models) is in the keiro schema. + Right (inApp, inKiroku, keiroMeta) <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + (,,) + <$> Tx.statement ("app_reads", "placed_counter") pgTableCountStmt + <*> Tx.statement ("kiroku", "placed_counter") pgTableCountStmt + <*> Tx.statement ("keiro", "keiro_read_models") pgTableCountStmt + inApp `shouldBe` (1 :: Int) + inKiroku `shouldBe` (0 :: Int) + keiroMeta `shouldBe` (1 :: Int) + + describe "Keiro.ReadModel" $ around (withFreshStore fixture) $ do + it "queries inline projection with Eventual consistency" $ \_ -> + withFreshResourceStore fixture $ \(storeHandle, StoreRunner runner) -> do + Right () <- + Store.runStoreIO storeHandle $ + initializeRegisteredReadModel counterReadModel initializeCounterReadModelTable + let target = stream "read-model-inline" :: Stream CounterEventStream + result <- + runner $ + runCommandWithProjections + defaultRunCommandOptions + counterEventStream + target + (Add 5) + [counterInlineProjection] + case result of + Right (Right commandResult) -> + commandResult ^. #globalPosition `shouldSatisfy` isJust + other -> expectationFailure ("expected inline projection command, got " <> show other) + queryResult <- + Store.runStoreIO storeHandle $ + runQuery Nothing counterReadModel "inline" + queryResult `shouldBe` Right (Right 5) + + it "reads the minimum checkpoint across consumer-group subscription members" $ \storeHandle -> do + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ do + Tx.statement ("counter-read-model-sub", 1, 7) upsertSubscriptionCursorMemberStmt + Tx.statement ("counter-read-model-sub", 2, 3) upsertSubscriptionCursorMemberStmt + position <- + Store.runStoreIO storeHandle $ + readSubscriptionPosition "counter-read-model-sub" + position `shouldBe` Right (Just (GlobalPosition 3)) + + it "Strong returns immediately on an empty log" $ \storeHandle -> do + Right () <- + Store.runStoreIO storeHandle $ + initializeRegisteredReadModel counterReadModel initializeCounterReadModelTable + queryResult <- + Store.runStoreIO storeHandle $ + runQueryWith Nothing Strong counterReadModel "empty" + queryResult `shouldBe` Right (Right 0) + + it "Strong returns immediately when the subscription is already at the store head" $ \_ -> + withFreshResourceStore fixture $ \(storeHandle, StoreRunner runner) -> do + Right () <- + Store.runStoreIO storeHandle $ + initializeRegisteredReadModel counterReadModel initializeCounterReadModelTable + let target = stream "read-model-strong-at-head" :: Stream CounterEventStream + Right (Right commandResult) <- + runner $ + runCommandWithProjections + defaultRunCommandOptions + counterEventStream + target + (Add 5) + [counterInlineProjection] + globalPosition <- case commandResult ^. #globalPosition of + Just position -> pure position + Nothing -> expectationFailure "expected command global position" *> error "unreachable" + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + Tx.statement ("counter-read-model-sub", globalPositionToInt globalPosition) upsertSubscriptionCursorStmt + queryResult <- + Store.runStoreIO storeHandle $ + runQueryWith Nothing Strong counterReadModel "inline" + queryResult `shouldBe` Right (Right 5) + + it "Strong blocks until the subscription reaches the store head captured at query start" $ \_ -> + withFreshResourceStore fixture $ \(storeHandle, StoreRunner runner) -> do + Right () <- + Store.runStoreIO storeHandle $ + initializeRegisteredReadModel counterReadModel initializeCounterReadModelTable + let target = stream "read-model-strong-blocking" :: Stream CounterEventStream + Right (Right commandResult) <- + runner $ + runCommandWithProjections + defaultRunCommandOptions + counterEventStream + target + (Add 6) + [counterInlineProjection] + globalPosition <- case commandResult ^. #globalPosition of + Just position -> pure position + Nothing -> expectationFailure "expected command global position" *> error "unreachable" + _ <- forkIO $ do + threadDelay 20000 + advanced <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + Tx.statement ("counter-read-model-sub", globalPositionToInt globalPosition) upsertSubscriptionCursorStmt + case advanced of + Right () -> pure () + Left err -> expectationFailure ("failed to advance subscription cursor: " <> show err) + queryResult <- + Store.runStoreIO storeHandle $ + runQueryWith Nothing Strong counterReadModel "inline" + queryResult `shouldBe` Right (Right 6) + + it "Strong returns when its category is caught up despite another active category" $ \_ -> + withFreshResourceStore fixture $ \(storeHandle, StoreRunner runner) -> do + Right () <- + Store.runStoreIO storeHandle $ + initializeRegisteredReadModel counterReadModel initializeCounterReadModelTable + let counterTarget = stream "counter-strong-scope" :: Stream CounterEventStream + otherTarget = stream "otherload-1" :: Stream CounterEventStream + Right (Right counterResult) <- + runner $ + runCommandWithProjections + defaultRunCommandOptions + counterEventStream + counterTarget + (Add 8) + [counterInlineProjection] + counterPosition <- case counterResult ^. #globalPosition of + Just position -> pure position + Nothing -> expectationFailure "expected counter global position" *> error "unreachable" + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + Tx.statement + ("counter-read-model-sub", globalPositionToInt counterPosition) + upsertSubscriptionCursorStmt + Right (Right _) <- + Store.runStoreIO storeHandle $ + runCommand defaultRunCommandOptions counterEventStream otherTarget (Add 1) + queryResult <- + Store.runStoreIO storeHandle $ + runQueryWith Nothing Strong counterCategoryReadModel "inline" + queryResult `shouldBe` Right (Right 8) + + it "inline projection populates actor and source_event_id from command metadata" $ \_ -> + withFreshResourceStore fixture $ \(storeHandle, StoreRunner runner) -> do + Right () <- + Store.runStoreIO storeHandle $ + initializeRegisteredReadModel counterReadModel initializeCounterReadModelTable + let target = stream "read-model-inline-metadata" :: Stream CounterEventStream + opts = + defaultRunCommandOptions + & #metadata + ?~ object ["actor" Aeson..= ("agent-7" :: Text)] + Right (Right _) <- + runner $ + runCommandWithProjections opts counterEventStream target (Add 5) [counterInlineProjection] + Right row <- + Store.runStoreIO storeHandle $ + Store.runTransaction (Tx.statement "inline" selectCounterMetaStmt) + -- selectCounterMetaStmt returns (amount, actor, source_event_id). + row `shouldSatisfy` \(amount, actor, srcId) -> + amount == 5 && actor == Just "agent-7" && isJust srcId + + it "waits for async projection cursor with PositionWait" $ \_ -> + withFreshResourceStore fixture $ \(storeHandle, StoreRunner runner) -> do + Right () <- + Store.runStoreIO storeHandle $ + initializeRegisteredReadModel counterReadModel initializeCounterReadModelTable + let target = stream "read-model-position-wait" :: Stream CounterEventStream + Right (Right commandResult) <- + runner $ + runCommandWithProjections + defaultRunCommandOptions + counterEventStream + target + (Add 3) + [counterInlineProjection] + globalPosition <- case commandResult ^. #globalPosition of + Just position -> pure position + Nothing -> expectationFailure "expected command global position" *> error "unreachable" + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + Tx.statement ("counter-read-model-sub", globalPositionToInt globalPosition) upsertSubscriptionCursorStmt + queryResult <- + Store.runStoreIO storeHandle $ + runQueryWith + Nothing + (PositionWait (fastWaitOptions & #target .~ Just globalPosition)) + counterReadModel + "inline" + queryResult `shouldBe` Right (Right 3) + + it "times out when PositionWait target is not reached" $ \storeHandle -> do + Right () <- + Store.runStoreIO storeHandle $ + initializeRegisteredReadModel counterReadModel initializeCounterReadModelTable + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + Tx.statement ("counter-read-model-sub", 1) upsertSubscriptionCursorStmt + queryResult <- + Store.runStoreIO storeHandle $ + runQueryWith + Nothing + (PositionWait (fastWaitOptions & #target .~ Just (GlobalPosition 5))) + counterReadModel + "timeout" + queryResult + `shouldBe` Right + (Left (ReadModelWaitTimeout "counter-read-model" (GlobalPosition 5) (GlobalPosition 1))) + + it "does not write the registry row on repeated read-model queries" $ \storeHandle -> do + Right () <- + Store.runStoreIO storeHandle $ + initializeRegisteredReadModel counterReadModel initializeCounterReadModelTable + Right (Right 0) <- + Store.runStoreIO storeHandle $ + runQuery Nothing counterReadModel "no-churn" + Right xminBefore <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + Tx.statement "counter-read-model" readModelXminStmt + Right (Right 0) <- + Store.runStoreIO storeHandle $ + runQuery Nothing counterReadModel "no-churn" + Right xminAfter <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + Tx.statement "counter-read-model" readModelXminStmt + xminAfter `shouldBe` xminBefore + + it "rejects an unregistered model without creating a registry row" $ \storeHandle -> do + let unregistered :: ReadModel Text Int + unregistered = counterReadModel & #name .~ ("never-registered" :: Text) + queryResult <- + Store.runStoreIO storeHandle $ + runQuery Nothing unregistered "missing" + queryResult `shouldBe` Right (Left (ReadModelUnregistered "never-registered")) + found <- + Store.runStoreIO storeHandle $ + lookupReadModel "never-registered" + found `shouldBe` Right Nothing + + it "handles concurrent explicit read-model registration" $ \storeHandle -> do + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction initializeCounterReadModelTable + resultA <- newEmptyMVar + resultB <- newEmptyMVar + _ <- + forkIO $ + Store.runStoreIO storeHandle (registerReadModelDefinition counterReadModel) + >>= putMVar resultA + _ <- + forkIO $ + Store.runStoreIO storeHandle (registerReadModelDefinition counterReadModel) + >>= putMVar resultB + first <- takeMVar resultA + second <- takeMVar resultB + first `shouldBe` Right () + second `shouldBe` Right () + queryResult <- + Store.runStoreIO storeHandle $ + runQuery Nothing counterReadModel "concurrent" + queryResult `shouldBe` Right (Right 0) + + it "rejects stale read-model schema" $ \storeHandle -> do + Right () <- + Store.runStoreIO storeHandle $ + initializeRegisteredReadModel counterReadModel initializeCounterReadModelTable + Right (Right 0) <- + Store.runStoreIO storeHandle $ + runQuery Nothing counterReadModel "stale" + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + Tx.statement ("counter-read-model", 99) updateReadModelVersionStmt + queryResult <- + Store.runStoreIO storeHandle $ + runQuery Nothing counterReadModel "stale" + queryResult + `shouldBe` Right + (Left (ReadModelStaleSchema "counter-read-model" 1 99 "counter-read-model-v1" "counter-read-model-v1")) + + it "surfaces unknown read-model statuses with the raw status text" $ \storeHandle -> do + Right () <- + Store.runStoreIO storeHandle $ + initializeRegisteredReadModel counterReadModel initializeCounterReadModelTable + Right (Right 0) <- + Store.runStoreIO storeHandle $ + runQuery Nothing counterReadModel "unknown-status" + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + Tx.statement ("counter-read-model", "wedged") updateReadModelStatusStmt + queryResult <- + Store.runStoreIO storeHandle $ + runQuery Nothing counterReadModel "unknown-status" + queryResult + `shouldBe` Right + (Left (ReadModelNotLive "counter-read-model" (UnknownStatus "wedged"))) + + it "ignores duplicate async event by source_event_id" $ \storeHandle -> do + Right () <- + Store.runStoreIO storeHandle $ + initializeRegisteredReadModel counterReadModel initializeCounterReadModelTable + let target = stream "read-model-async-idempotent" :: Stream CounterEventStream + Right (Right _) <- + Store.runStoreIO storeHandle $ + runCommand defaultRunCommandOptions counterEventStream target (Add 7) + Right recorded <- + Store.runStoreIO storeHandle $ + Store.readStreamForward (StreamName "read-model-async-idempotent") (StreamVersion 0) 10 + event <- case Vector.toList recorded of + [onlyEvent] -> pure onlyEvent + other -> expectationFailure ("expected one event, got " <> show other) *> error "unreachable" + Right outcomes <- Store.runStoreIO storeHandle $ + Store.runTransaction $ do + first <- applyAsyncProjection counterAsyncProjection event + second <- applyAsyncProjection counterAsyncProjection event + pure (first, second) + outcomes `shouldBe` (AsyncApplied, AsyncDuplicate) + queryResult <- + Store.runStoreIO storeHandle $ + runQuery Nothing counterReadModel "async-idempotent" + queryResult `shouldBe` Right (Right 7) + + it "deduplicates async projection application across transactions and reopens after pruning" $ \storeHandle -> do + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction initializeProjectionDedupCounterTable + Right _ <- + Store.runStoreIO storeHandle $ + registerReadModel "projection-dedup-counter-model" 1 "projection-dedup-counter-v1" + let target = stream "read-model-async-dedup-window" :: Stream CounterEventStream + Right (Right _) <- + Store.runStoreIO storeHandle $ + runCommand defaultRunCommandOptions counterEventStream target (Add 7) + Right recorded <- + Store.runStoreIO storeHandle $ + Store.readStreamForward (StreamName "read-model-async-dedup-window") (StreamVersion 0) 10 + event <- case Vector.toList recorded of + [onlyEvent] -> pure onlyEvent + other -> expectationFailure ("expected one event, got " <> show other) *> error "unreachable" + let incrementingProjection = + AsyncProjection + { name = "incrementing-async-projection", + readModelName = "projection-dedup-counter-model", + subscriptionName = "incrementing-async-projection-sub", + applyRecorded = \_ -> Tx.statement () incrementProjectionDedupCounterStmt, + idempotencyKey = \recordedEvent -> recordedEvent ^. #eventId + } + Right AsyncApplied <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + applyAsyncProjection incrementingProjection event + Right AsyncDuplicate <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + applyAsyncProjection incrementingProjection event + Right countAfterDuplicate <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + Tx.statement () selectProjectionDedupCounterStmt + countAfterDuplicate `shouldBe` 1 + cutoff <- addUTCTime 1 <$> getCurrentTime + pruned <- Store.runStoreIO storeHandle $ pruneAsyncProjectionDedupBefore cutoff + pruned `shouldBe` Right 1 + Right AsyncApplied <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + applyAsyncProjection incrementingProjection event + Right countAfterPrune <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + Tx.statement () selectProjectionDedupCounterStmt + countAfterPrune `shouldBe` 2 + + it "rebuild repopulates the projection table through the supported workflow" $ \storeHandle -> do + Right () <- + Store.runStoreIO storeHandle $ + initializeRegisteredReadModel counterReadModel initializeCounterReadModelTable + let target = stream "read-model-rebuild-runbook" :: Stream CounterEventStream + Right (Right _) <- + Store.runStoreIO storeHandle $ + runCommand defaultRunCommandOptions counterEventStream target (Add 7) + Right recorded <- + Store.runStoreIO storeHandle $ + Store.readStreamForward (StreamName "read-model-rebuild-runbook") (StreamVersion 0) 10 + event <- case Vector.toList recorded of + [onlyEvent] -> pure onlyEvent + other -> expectationFailure ("expected one event, got " <> show other) *> error "unreachable" + Right AsyncApplied <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + applyAsyncProjection counterAsyncProjection event + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + Tx.statement + ( "counter-read-model-sub", + globalPositionToInt (event ^. #globalPosition) + ) + upsertSubscriptionCursorStmt + beforeRebuild <- + Store.runStoreIO storeHandle $ + runQuery Nothing counterReadModel "async-idempotent" + beforeRebuild `shouldBe` Right (Right 7) + + Right rebuilding <- + Store.runStoreIO storeHandle $ + Rebuild.startRebuild + counterReadModel + [counterAsyncProjection ^. #name] + (GlobalPosition 0) + rebuilding ^. #status `shouldBe` Rebuilding + checkpointAfterReset <- + Store.runStoreIO storeHandle $ + readSubscriptionPosition "counter-read-model-sub" + checkpointAfterReset `shouldBe` Right (Just (GlobalPosition 0)) + Right AsyncApplied <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + applyAsyncProjectionUnfenced counterAsyncProjection event + Right (Right live) <- + Store.runStoreIO storeHandle $ + Rebuild.finishRebuild + counterReadModel + [counterAsyncProjection ^. #name] + (GlobalPosition 0) + live ^. #status `shouldBe` Live + + afterRebuild <- + Store.runStoreIO storeHandle $ + runQuery Nothing counterReadModel "async-idempotent" + afterRebuild `shouldBe` Right (Right 7) + + it "keeps a non-empty-log rebuild offline when replay applies nothing" $ \storeHandle -> do + Right () <- + Store.runStoreIO storeHandle $ + initializeRegisteredReadModel counterReadModel initializeCounterReadModelTable + let target = stream "read-model-rebuild-empty-replay" :: Stream CounterEventStream + Right (Right _) <- + Store.runStoreIO storeHandle $ + runCommand defaultRunCommandOptions counterEventStream target (Add 7) + Right _ <- + Store.runStoreIO storeHandle $ + Rebuild.startRebuild + counterReadModel + [counterAsyncProjection ^. #name] + (GlobalPosition 0) + finishResult <- + Store.runStoreIO storeHandle $ + Rebuild.finishRebuild + counterReadModel + [counterAsyncProjection ^. #name] + (GlobalPosition 0) + case finishResult of + Right (Left (Rebuild.RebuildProducedNoApplies modelName headPosition)) -> do + modelName `shouldBe` "counter-read-model" + headPosition `shouldSatisfy` (> GlobalPosition 0) + other -> expectationFailure ("expected zero-apply guard, got " <> show other) + queryResult <- + Store.runStoreIO storeHandle $ + runQuery Nothing counterReadModel "async-idempotent" + queryResult + `shouldBe` Right + (Left (ReadModelNotLive "counter-read-model" Rebuilding)) + + it "fences live async application while a model is rebuilding" $ \storeHandle -> do + Right () <- + Store.runStoreIO storeHandle $ + initializeRegisteredReadModel counterReadModel initializeCounterReadModelTable + let target = stream "read-model-fenced-apply" :: Stream CounterEventStream + Right (Right _) <- + Store.runStoreIO storeHandle $ + runCommand defaultRunCommandOptions counterEventStream target (Add 7) + Right recorded <- + Store.runStoreIO storeHandle $ + Store.readStreamForward (StreamName "read-model-fenced-apply") (StreamVersion 0) 10 + event <- case Vector.toList recorded of + [onlyEvent] -> pure onlyEvent + other -> expectationFailure ("expected one event, got " <> show other) *> error "unreachable" + Right _ <- + Store.runStoreIO storeHandle $ + Rebuild.startRebuild + counterReadModel + [counterAsyncProjection ^. #name] + (GlobalPosition 0) + outcome <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + applyAsyncProjection counterAsyncProjection event + outcome `shouldBe` Right AsyncFenced + Right dedupCount <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + Tx.statement (counterAsyncProjection ^. #name) projectionDedupCountStmt + dedupCount `shouldBe` 0 + Right amount <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + Tx.statement "async-idempotent" selectCounterReadModelStmt + amount `shouldBe` 0 + + it "keeps a live applier out of the rebuild window and reopens it after promotion" $ \storeHandle -> do + Right () <- + Store.runStoreIO storeHandle $ + initializeRegisteredReadModel counterReadModel initializeCounterReadModelTable + let target = stream "read-model-fence-race" :: Stream CounterEventStream + Right (Right _) <- + Store.runStoreIO storeHandle $ + runCommand defaultRunCommandOptions counterEventStream target (Add 7) + Right recorded <- + Store.runStoreIO storeHandle $ + Store.readStreamForward (StreamName "read-model-fence-race") (StreamVersion 0) 10 + event <- case Vector.toList recorded of + [onlyEvent] -> pure onlyEvent + other -> expectationFailure ("expected one event, got " <> show other) *> error "unreachable" + enterRebuildWindow <- newEmptyMVar + liveApplyResult <- newEmptyMVar + _ <- + forkIO $ do + takeMVar enterRebuildWindow + Store.runStoreIO + storeHandle + (Store.runTransaction (applyAsyncProjection counterAsyncProjection event)) + >>= putMVar liveApplyResult + Right _ <- + Store.runStoreIO storeHandle $ + Rebuild.startRebuild + counterReadModel + [counterAsyncProjection ^. #name] + (GlobalPosition 0) + putMVar enterRebuildWindow () + takeMVar liveApplyResult `shouldReturn` Right AsyncFenced + + Right AsyncApplied <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + applyAsyncProjectionUnfenced counterAsyncProjection event + Right (Right _) <- + Store.runStoreIO storeHandle $ + Rebuild.finishRebuild + counterReadModel + [counterAsyncProjection ^. #name] + (GlobalPosition 0) + cutoff <- addUTCTime 1 <$> getCurrentTime + pruned <- Store.runStoreIO storeHandle $ pruneAsyncProjectionDedupBefore cutoff + pruned `shouldBe` Right 1 + reapplied <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + applyAsyncProjection counterAsyncProjection event + reapplied `shouldBe` Right AsyncApplied + queryResult <- + Store.runStoreIO storeHandle $ + runQuery Nothing counterReadModel "async-idempotent" + queryResult `shouldBe` Right (Right 7) + + it "tracks rebuild state transitions" $ \storeHandle -> do + Right () <- + Store.runStoreIO storeHandle $ + registerReadModelDefinition counterReadModel + Right rebuilding <- + Store.runStoreIO storeHandle $ + Rebuild.rebuild counterReadModel + rebuilding ^. #status `shouldBe` Rebuilding + Right live <- + Store.runStoreIO storeHandle $ + Rebuild.promote counterReadModel + live ^. #status `shouldBe` Live + Right abandoned <- + Store.runStoreIO storeHandle $ + Rebuild.abandonRebuild counterReadModel + abandoned ^. #status `shouldBe` Abandoned + + it "records projection lag behind the log head" $ \storeHandle -> do + (exporter, metricsRef) <- inMemoryMetricExporter + (provider, _env) <- + createMeterProvider + emptyMaterializedResources + defaultSdkMeterProviderOptions {metricExporter = Just exporter} + meter <- getMeter provider Telemetry.keiroInstrumentationLibrary + keiroMetrics <- Telemetry.newKeiroMetrics meter + Right () <- + Store.runStoreIO storeHandle $ + initializeRegisteredReadModel counterReadModel initializeCounterReadModelTable + let target = stream "read-model-lag" :: Stream CounterEventStream + Right (Right _) <- + Store.runStoreIO storeHandle $ + runCommand defaultRunCommandOptions counterEventStream target (Add 1) + Right (Right _) <- + Store.runStoreIO storeHandle $ + runCommand defaultRunCommandOptions counterEventStream target (Add 1) + -- The subscription cursor is never advanced, so the read model is behind + -- the head by every appended event: the lag gauge records that gap. + Right () <- + Store.runStoreIO storeHandle $ + recordProjectionLag (Just keiroMetrics) counterAsyncProjection + _ <- forceFlushMeterProvider provider Nothing + exported <- readIORef metricsRef + let scalars = flattenScalarPoints exported + case lookup "keiro.projection.lag" scalars of + Just (IntNumber n) -> n `shouldSatisfy` (>= 1) + other -> expectationFailure ("expected an integer projection lag, got " <> show other) + + it "counts a position-wait timeout in the timeout counter" $ \storeHandle -> do + (exporter, metricsRef) <- inMemoryMetricExporter + (provider, _env) <- + createMeterProvider + emptyMaterializedResources + defaultSdkMeterProviderOptions {metricExporter = Just exporter} + meter <- getMeter provider Telemetry.keiroInstrumentationLibrary + keiroMetrics <- Telemetry.newKeiroMetrics meter + Right () <- + Store.runStoreIO storeHandle $ + initializeRegisteredReadModel counterReadModel initializeCounterReadModelTable + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + Tx.statement ("counter-read-model-sub", 1) upsertSubscriptionCursorStmt + queryResult <- + Store.runStoreIO storeHandle $ + runQueryWith + (Just keiroMetrics) + (PositionWait (fastWaitOptions & #target .~ Just (GlobalPosition 5))) + counterReadModel + "timeout" + queryResult + `shouldBe` Right + (Left (ReadModelWaitTimeout "counter-read-model" (GlobalPosition 5) (GlobalPosition 1))) + _ <- forceFlushMeterProvider provider Nothing + exported <- readIORef metricsRef + let scalars = flattenScalarPoints exported + -- The single give-up bumped the counter exactly once. + lookup "keiro.projection.wait.timeouts" scalars `shouldBe` Just (IntNumber 1) + + describe "Keiro.ProcessManager" $ around (withFreshResourceStore fixture) $ do + it "advances manager state, emits a deterministic target command once, and schedules a timer" $ \(_storeHandle, StoreRunner _runner) -> do + let sourceEvent = recordedFromEventId (EventId sampleUuid) (CounterAdded 9) + result <- + _runner $ + runProcessManagerOnce defaultRunCommandOptions counterProcessManager sourceEvent (CounterAdded 9) + case result of + Right (Right pmResult) -> do + case pmResult ^. #managerResult of + PMStateAppended managerResult -> + managerResult ^. #streamVersion `shouldBe` StreamVersion 1 + other -> expectationFailure ("expected appended manager state, got " <> show other) + case pmResult ^. #commandResults of + [PMCommandAppended commandResult] -> + commandResult ^. #eventsAppended `shouldBe` 1 + other -> expectationFailure ("expected one emitted command, got " <> show other) + pmResult ^. #timersScheduled `shouldBe` 1 + other -> expectationFailure ("expected process-manager success, got " <> show other) + Right managerEvents <- + _runner $ + Store.readStreamForward (StreamName "pm:counter-order-1") (StreamVersion 0) 10 + Right targetEvents <- + _runner $ + Store.readStreamForward (StreamName "counter-target-order-1") (StreamVersion 0) 10 + Vector.length managerEvents `shouldBe` 1 + Vector.length targetEvents `shouldBe` 1 + timer <- + _runner $ + claimDueTimer dueTimerTime + case timer of + Right (Just row) -> do + row ^. #processManagerName `shouldBe` "counter-pm" + row ^. #correlationId `shouldBe` "order-1" + other -> expectationFailure ("expected scheduled timer row, got " <> show other) + + it "schedules timers when the manager command emits no events" $ \(_storeHandle, StoreRunner _runner) -> do + let sourceEvent = recordedFromEventId (EventId sampleUuid) (CounterAdded 9) + result <- + _runner $ + runProcessManagerOnce defaultRunCommandOptions timerOnlyProcessManager sourceEvent (CounterAdded 9) + case result of + Right (Right pmResult) -> do + case pmResult ^. #managerResult of + PMStateAppended managerResult -> do + managerResult ^. #streamVersion `shouldBe` StreamVersion 0 + managerResult ^. #eventsAppended `shouldBe` 0 + other -> expectationFailure ("expected no-op manager state, got " <> show other) + pmResult ^. #commandResults `shouldBe` [] + pmResult ^. #timersScheduled `shouldBe` 1 + other -> expectationFailure ("expected process-manager success, got " <> show other) + dueCount <- + _runner $ + countDueTimers dueTimerTime + dueCount `shouldBe` Right 1 + timer <- + _runner $ + claimDueTimer dueTimerTime + case timer of + Right (Just row) -> do + row ^. #processManagerName `shouldBe` "timer-only-pm" + row ^. #correlationId `shouldBe` "order-1" + other -> expectationFailure ("expected scheduled timer row, got " <> show other) + + it "treats duplicate input delivery as idempotent state and command dispatch" $ \(_storeHandle, StoreRunner _runner) -> do + let sourceEvent = recordedFromEventId (EventId sampleUuid2) (CounterAdded 4) + Right (Right _) <- + _runner $ + runProcessManagerOnce defaultRunCommandOptions counterProcessManager sourceEvent (CounterAdded 4) + duplicate <- + _runner $ + runProcessManagerOnce defaultRunCommandOptions counterProcessManager sourceEvent (CounterAdded 4) + case duplicate of + Right (Right pmResult) -> do + pmResult ^. #managerResult `shouldSatisfy` \case + PMStateDuplicate {} -> True + _ -> False + pmResult ^. #commandResults `shouldSatisfy` \case + [PMCommandDuplicate {}] -> True + _ -> False + other -> expectationFailure ("expected idempotent duplicate handling, got " <> show other) + Right managerEvents <- + _runner $ + Store.readStreamForward (StreamName "pm:counter-order-1") (StreamVersion 0) 10 + Right targetEvents <- + _runner $ + Store.readStreamForward (StreamName "counter-target-order-1") (StreamVersion 0) 10 + Vector.length managerEvents `shouldBe` 1 + Vector.length targetEvents `shouldBe` 1 + + it "replays a Kiroku dead letter freshly and deduplicates a second replay" $ \(_storeHandle, StoreRunner _runner) -> do + let subName = SubscriptionName "counter-pm-replay-fresh" + replayHandler recorded = + case decodeRecorded counterCodec recorded of + Left err -> pure (Left (Text.pack (show err))) + Right input -> do + outcome <- + runProcessManagerOnce + defaultRunCommandOptions + counterProcessManager + recorded + input + pure $ + case outcome of + Left err -> Left (Text.pack (show err)) + Right result -> Right (classifyProcessManagerReplay result) + source <- deadLetterCounterSource _storeHandle subName (CounterAdded 7) + Right listed <- _runner (listSubscriptionDeadLetters subName 0) + Vector.length listed `shouldBe` 1 + + Right firstPass <- + _runner $ + replaySubscriptionDeadLetters subName 0 replayHandler + firstPass + `shouldBe` [ ReplayOutcome + { replayGlobalPosition = source ^. #globalPosition, + replayEventId = source ^. #eventId, + replayResult = ReplayedFresh + } + ] + processManagerReplayCounts _storeHandle `shouldReturn` (1, 1) + + Right secondPass <- + _runner $ + replaySubscriptionDeadLetters subName 0 replayHandler + secondPass + `shouldBe` [ ReplayOutcome + { replayGlobalPosition = source ^. #globalPosition, + replayEventId = source ^. #eventId, + replayResult = ReplayedDuplicate + } + ] + processManagerReplayCounts _storeHandle `shouldReturn` (1, 1) + Right retained <- _runner (listSubscriptionDeadLetters subName 0) + Vector.length retained `shouldBe` 1 + + it "reports an already-processed Kiroku dead letter without appending" $ \(_storeHandle, StoreRunner _runner) -> do + let subName = SubscriptionName "counter-pm-replay-duplicate" + replayHandler recorded = + case decodeRecorded counterCodec recorded of + Left err -> pure (Left (Text.pack (show err))) + Right input -> do + outcome <- + runProcessManagerOnce + defaultRunCommandOptions + counterProcessManager + recorded + input + pure $ + case outcome of + Left err -> Left (Text.pack (show err)) + Right result -> Right (classifyProcessManagerReplay result) + source <- deadLetterCounterSource _storeHandle subName (CounterAdded 8) + Right (Right _) <- + _runner $ + runProcessManagerOnce + defaultRunCommandOptions + counterProcessManager + source + (CounterAdded 8) + countsBefore <- processManagerReplayCounts _storeHandle + + Right outcomes <- + _runner $ + replaySubscriptionDeadLetters subName 0 replayHandler + outcomes + `shouldBe` [ ReplayOutcome + { replayGlobalPosition = source ^. #globalPosition, + replayEventId = source ^. #eventId, + replayResult = ReplayedDuplicate + } + ] + processManagerReplayCounts _storeHandle `shouldReturn` countsBefore + + it "keeps multiple workflow process managers isolated by configured streams and categories" $ \(_storeHandle, StoreRunner _runner) -> do + let sourceEvent = recordedFromEventId (EventId sampleUuid) (CounterAdded 6) + fulfillmentManager = + workflowProcessManager + "fulfillment-pm" + "pm:fulfillment" + "fulfillment-target-order-1" + billingManager = + workflowProcessManager + "billing-pm" + "pm:billing" + "billing-target-order-1" + fulfillmentResult <- + _runner $ + runProcessManagerOnce defaultRunCommandOptions fulfillmentManager sourceEvent (CounterAdded 6) + billingResult <- + _runner $ + runProcessManagerOnce defaultRunCommandOptions billingManager sourceEvent (CounterAdded 6) + assertWorkflowProcessManagerAppended fulfillmentResult + assertWorkflowProcessManagerAppended billingResult + + Right fulfillmentManagerEvents <- + _runner $ + Store.readStreamForward (StreamName "pm:fulfillment-order-1") (StreamVersion 0) 10 + Right billingManagerEvents <- + _runner $ + Store.readStreamForward (StreamName "pm:billing-order-1") (StreamVersion 0) 10 + Right fulfillmentTargetEvents <- + _runner $ + Store.readStreamForward (StreamName "fulfillment-target-order-1") (StreamVersion 0) 10 + Right billingTargetEvents <- + _runner $ + Store.readStreamForward (StreamName "billing-target-order-1") (StreamVersion 0) 10 + Vector.length fulfillmentManagerEvents `shouldBe` 1 + Vector.length billingManagerEvents `shouldBe` 1 + Vector.length fulfillmentTargetEvents `shouldBe` 1 + Vector.length billingTargetEvents `shouldBe` 1 + + Right fulfillmentCategoryEvents <- + _runner $ + Store.readCategory (CategoryName "pm:fulfillment") (GlobalPosition 0) 10 + Right billingCategoryEvents <- + _runner $ + Store.readCategory (CategoryName "pm:billing") (GlobalPosition 0) 10 + Right sharedPmCategoryEvents <- + _runner $ + Store.readCategory (CategoryName "pm") (GlobalPosition 0) 10 + Right sharedPmNamespaceEvents <- + _runner $ + Store.readCategory (CategoryName "pm:") (GlobalPosition 0) 10 + Vector.length fulfillmentCategoryEvents `shouldBe` 1 + Vector.length billingCategoryEvents `shouldBe` 1 + sharedPmCategoryEvents `shouldBe` Vector.empty + sharedPmNamespaceEvents `shouldBe` Vector.empty + + it "worker finalizes AckOk through the ack handle on success" $ \(_storeHandle, StoreRunner _runner) -> do + decisionsRef <- newIORef [] + let sourceEvent = recordedFromEventId (EventId sampleUuid) (CounterAdded 9) + messages = [(sourceEvent, CounterAdded 9)] + adapter = inMemoryAdapter decisionsRef messages + Right () <- + _runner $ + runProcessManagerWorker defaultRunCommandOptions counterProcessManager adapter Just + decisions <- readIORef decisionsRef + decisions `shouldBe` [AckOk] + + it "worker halts instead of acking when a target dispatch is rejected" $ \(_storeHandle, StoreRunner _runner) -> do + decisionsRef <- newIORef [] + let sourceEvent = recordedFromEventId (EventId sampleUuid) (CounterAdded 9) + messages = [(sourceEvent, CounterAdded 9)] + adapter = inMemoryAdapter decisionsRef messages + rejectingPm = + (counterProcessManager :: ProcessManager CounterEvent (HsPred '[] CounterCommand) '[] CounterState CounterCommand CounterEvent (HsPred '[] CounterCommand) '[] CounterState CounterCommand CounterEvent) + { targetEventStream = rejectingEventStream + } + Right () <- + _runner $ + runProcessManagerWorker defaultRunCommandOptions rejectingPm adapter Just + decisions <- readIORef decisionsRef + decisions `shouldSatisfy` \case + [AckHalt (HaltFatal _)] -> True + _ -> False + Right targetEvents <- + _runner $ + Store.readStreamForward (StreamName "counter-target-order-1") (StreamVersion 0) 10 + Right managerEvents <- + _runner $ + Store.readStreamForward (StreamName "pm:counter-order-1") (StreamVersion 0) 10 + Vector.length targetEvents `shouldBe` 0 + Vector.length managerEvents `shouldBe` 1 + + it "dead-letters a rejected dispatch and continues to the next event" $ \(_storeHandle, StoreRunner _runner) -> do + (exporter, metricsRef) <- inMemoryMetricExporter + (provider, _env) <- + createMeterProvider + emptyMaterializedResources + defaultSdkMeterProviderOptions {metricExporter = Just exporter} + meter <- getMeter provider Telemetry.keiroInstrumentationLibrary + keiroMetrics <- Telemetry.newKeiroMetrics meter + decisionsRef <- newIORef [] + let first = recordedFromEventId (EventId sampleUuid) (CounterAdded 9) + second = recordedFromEventId (EventId sampleUuid2) (CounterAdded 1) + messages = [(first, CounterAdded 9), (second, CounterAdded 1)] + adapter = inMemoryAdapter decisionsRef messages + policyPm = + (counterProcessManager :: ProcessManager CounterEvent (HsPred '[] CounterCommand) '[] CounterState CounterCommand CounterEvent (HsPred '[] CounterCommand) '[] CounterState CounterCommand CounterEvent) + { targetEventStream = rejectNineEventStream + } + workerOptions = + defaultWorkerOptions + & #rejectedCommandPolicy + .~ RejectedDeadLetter + & #metrics + ?~ keiroMetrics + Right () <- + _runner $ + runProcessManagerWorkerWith workerOptions defaultRunCommandOptions policyPm adapter Just + readIORef decisionsRef `shouldReturn` [AckOk, AckOk] + Right deadLetters <- _runner (listDispatchDeadLetters "counter-pm") + case deadLetters of + [row] -> do + row ^. #dispatcherKind `shouldBe` DispatcherProcessManager + row ^. #correlationId `shouldBe` "order-1" + row ^. #sourceEventId `shouldBe` EventId sampleUuid + row ^. #emitIndex `shouldBe` 0 + row ^. #targetStreamName `shouldBe` StreamName "counter-target-order-1" + row ^. #errorClass `shouldBe` "command_rejected" + row ^. #attemptCount `shouldBe` 1 + other -> expectationFailure ("expected one rejected dispatch dead letter, got " <> show other) + Right targetEvents <- + _runner $ + Store.readStreamForward (StreamName "counter-target-order-1") (StreamVersion 0) 10 + Right managerEvents <- + _runner $ + Store.readStreamForward (StreamName "pm:counter-order-1") (StreamVersion 0) 10 + Vector.length targetEvents `shouldBe` 1 + Vector.length managerEvents `shouldBe` 2 + _ <- forceFlushMeterProvider provider Nothing + exported <- readIORef metricsRef + lookup "keiro.dispatch.deadlettered" (flattenScalarPoints exported) `shouldBe` Just (IntNumber 1) + + it "skips a rejected dispatch without writing a dead-letter row" $ \(_storeHandle, StoreRunner _runner) -> do + (exporter, metricsRef) <- inMemoryMetricExporter + (provider, _env) <- + createMeterProvider + emptyMaterializedResources + defaultSdkMeterProviderOptions {metricExporter = Just exporter} + meter <- getMeter provider Telemetry.keiroInstrumentationLibrary + keiroMetrics <- Telemetry.newKeiroMetrics meter + decisionsRef <- newIORef [] + let sourceEvent = recordedFromEventId (EventId sampleUuid) (CounterAdded 9) + adapter = inMemoryAdapter decisionsRef [(sourceEvent, CounterAdded 9)] + rejectingPm = + (counterProcessManager :: ProcessManager CounterEvent (HsPred '[] CounterCommand) '[] CounterState CounterCommand CounterEvent (HsPred '[] CounterCommand) '[] CounterState CounterCommand CounterEvent) + { targetEventStream = rejectingEventStream + } + workerOptions = + defaultWorkerOptions + & #rejectedCommandPolicy + .~ RejectedSkip + & #metrics + ?~ keiroMetrics + Right () <- + _runner $ + runProcessManagerWorkerWith workerOptions defaultRunCommandOptions rejectingPm adapter Just + readIORef decisionsRef `shouldReturn` [AckOk] + Right deadLetters <- _runner (listDispatchDeadLetters "counter-pm") + deadLetters `shouldBe` [] + _ <- forceFlushMeterProvider provider Nothing + exported <- readIORef metricsRef + lookup "keiro.dispatch.deadlettered" (flattenScalarPoints exported) `shouldBe` Just (IntNumber 1) + + it "dead-letters a manager-state rejection at emit index minus one" $ \(_storeHandle, StoreRunner _runner) -> do + decisionsRef <- newIORef [] + let sourceEvent = recordedFromEventId (EventId sampleUuid) (CounterAdded 9) + adapter = inMemoryAdapter decisionsRef [(sourceEvent, CounterAdded 9)] + rejectingManager = + (counterProcessManager :: ProcessManager CounterEvent (HsPred '[] CounterCommand) '[] CounterState CounterCommand CounterEvent (HsPred '[] CounterCommand) '[] CounterState CounterCommand CounterEvent) + { eventStream = rejectingEventStream + } + workerOptions = defaultWorkerOptions & #rejectedCommandPolicy .~ RejectedDeadLetter + Right () <- + _runner $ + runProcessManagerWorkerWith workerOptions defaultRunCommandOptions rejectingManager adapter Just + readIORef decisionsRef `shouldReturn` [AckOk] + Right deadLetters <- _runner (listDispatchDeadLetters "counter-pm") + case deadLetters of + [row] -> do + row ^. #emitIndex `shouldBe` (-1) + row ^. #targetStreamName `shouldBe` StreamName "pm:counter-order-1" + row ^. #errorClass `shouldBe` "command_rejected" + other -> expectationFailure ("expected one manager-state dead letter, got " <> show other) + Right managerEvents <- + _runner $ + Store.readStreamForward (StreamName "pm:counter-order-1") (StreamVersion 0) 10 + managerEvents `shouldBe` Vector.empty + + it "keeps rejected-dispatch dead letters idempotent on source redelivery" $ \(_storeHandle, StoreRunner _runner) -> do + decisionsRef <- newIORef [] + let sourceEvent = recordedFromEventId (EventId sampleUuid) (CounterAdded 9) + adapter = inMemoryAdapter decisionsRef [(sourceEvent, CounterAdded 9), (sourceEvent, CounterAdded 9)] + rejectingPm = + (counterProcessManager :: ProcessManager CounterEvent (HsPred '[] CounterCommand) '[] CounterState CounterCommand CounterEvent (HsPred '[] CounterCommand) '[] CounterState CounterCommand CounterEvent) + { targetEventStream = rejectingEventStream + } + workerOptions = defaultWorkerOptions & #rejectedCommandPolicy .~ RejectedDeadLetter + Right () <- + _runner $ + runProcessManagerWorkerWith workerOptions defaultRunCommandOptions rejectingPm adapter Just + readIORef decisionsRef `shouldReturn` [AckOk, AckOk] + Right deadLetters <- _runner (listDispatchDeadLetters "counter-pm") + Prelude.length deadLetters `shouldBe` 1 + + it "records dispatch failures through worker metrics" $ \(_storeHandle, StoreRunner _runner) -> do + (exporter, metricsRef) <- inMemoryMetricExporter + (provider, _env) <- + createMeterProvider + emptyMaterializedResources + defaultSdkMeterProviderOptions {metricExporter = Just exporter} + meter <- getMeter provider Telemetry.keiroInstrumentationLibrary + keiroMetrics <- Telemetry.newKeiroMetrics meter + decisionsRef <- newIORef [] + let sourceEvent = recordedFromEventId (EventId sampleUuid) (CounterAdded 9) + messages = [(sourceEvent, CounterAdded 9)] + adapter = inMemoryAdapter decisionsRef messages + rejectingPm = + (counterProcessManager :: ProcessManager CounterEvent (HsPred '[] CounterCommand) '[] CounterState CounterCommand CounterEvent (HsPred '[] CounterCommand) '[] CounterState CounterCommand CounterEvent) + { targetEventStream = rejectingEventStream + } + workerOptions = defaultWorkerOptions & #metrics ?~ keiroMetrics + Right () <- + _runner $ + runProcessManagerWorkerWith workerOptions defaultRunCommandOptions rejectingPm adapter Just + _ <- forceFlushMeterProvider provider Nothing + exported <- readIORef metricsRef + lookup "keiro.dispatch.failed" (flattenScalarPoints exported) `shouldBe` Just (IntNumber 1) + + it "classifies transient store failures as retry and deterministic command failures as halt" $ \(_storeHandle, StoreRunner _runner) -> do + isRejectionClass CommandRejected `shouldBe` True + isRejectionClass (CommandAmbiguous [0, 1]) `shouldBe` True + isRejectionClass (EncodeFailed (NonObjectCallerMetadata Aeson.Null)) `shouldBe` False + ackForCommandError (RetryDelay 5) (StoreFailed (Store.ConnectionLost "boom")) + `shouldBe` AckRetry (RetryDelay 5) + ackForCommandError (RetryDelay 5) CommandRejected `shouldSatisfy` \case + AckHalt (HaltFatal _) -> True + _ -> False + ackForCommandError (RetryDelay 5) (CommandAmbiguous [0, 1]) `shouldSatisfy` \case + AckHalt (HaltFatal _) -> True + _ -> False + + it "worker applies poison-message policy on decode failure" $ \(_storeHandle, StoreRunner _runner) -> do + let badMessages = ["not-decodable" :: Text] + defaultDecisions <- newIORef [] + Right () <- + _runner $ + runProcessManagerWorker + defaultRunCommandOptions + counterProcessManager + (inMemoryAdapter defaultDecisions badMessages) + (const Nothing) + defaultObserved <- readIORef defaultDecisions + defaultObserved `shouldSatisfy` \case + [AckHalt (HaltFatal _)] -> True + _ -> False + + skippedRef <- newIORef [] + skipDecisions <- newIORef [] + let skipOptions = + defaultWorkerOptions + & #poisonPolicy + .~ PoisonSkip (\env -> liftIO (modifyIORef' skippedRef (<> [env ^. #payload]))) + Right () <- + _runner $ + runProcessManagerWorkerWith + skipOptions + defaultRunCommandOptions + counterProcessManager + (inMemoryAdapter skipDecisions badMessages) + (const Nothing) + readIORef skipDecisions `shouldReturn` [AckOk] + readIORef skippedRef `shouldReturn` badMessages + + deadLetterDecisions <- newIORef [] + deadLetterRef <- newIORef [] + let deadLetterOptions = + defaultWorkerOptions + & #poisonPolicy + .~ PoisonDeadLetter (\env -> liftIO (modifyIORef' deadLetterRef (<> [env ^. #payload]))) + Right () <- + _runner $ + runProcessManagerWorkerWith + deadLetterOptions + defaultRunCommandOptions + counterProcessManager + (inMemoryAdapter deadLetterDecisions badMessages) + (const Nothing) + deadLetterObserved <- readIORef deadLetterDecisions + deadLetterObserved `shouldSatisfy` \case + [AckDeadLetter (InvalidPayload _)] -> True + _ -> False + readIORef deadLetterRef `shouldReturn` badMessages + + it "folds a concurrent duplicate target dispatch to PMCommandDuplicate" $ \(_storeHandle, StoreRunner _runner) -> do + insertCount <- newIORef (0 :: Int) + let sourceEvent = recordedFromEventId (EventId sampleUuid) (CounterAdded 9) + commandId = deterministicCommandId "counter-pm" "order-1" (sourceEvent ^. #eventId) 0 + targetStreamName = StreamName "counter-target-order-1" + insertConcurrentTarget = do + callNo <- atomicModifyIORef' insertCount (\n -> (n + 1, n)) + when (callNo == 1) $ appendCounterEventWithId _storeHandle targetStreamName commandId (CounterAdded 9) + options = + defaultRunCommandOptions + & #beforeAppend + .~ insertConcurrentTarget + & #retryBackoffMicros + .~ 0 + result <- + _runner $ + runProcessManagerOnce options counterProcessManager sourceEvent (CounterAdded 9) + case result of + Right (Right pmResult) -> + pmResult ^. #commandResults `shouldSatisfy` \case + [PMCommandDuplicate duplicateId] -> duplicateId == commandId + _ -> False + other -> expectationFailure ("expected duplicate target dispatch fold, got " <> show other) + Right targetEvents <- + _runner $ + Store.readStreamForward targetStreamName (StreamVersion 0) 10 + Vector.length targetEvents `shouldBe` 1 + + it "folds a concurrent duplicate manager-state append to PMStateDuplicate" $ \(_storeHandle, StoreRunner _runner) -> do + insertCount <- newIORef (0 :: Int) + let sourceEvent = recordedFromEventId (EventId sampleUuid) (CounterAdded 9) + managerId = deterministicCommandId "counter-pm" "order-1" (sourceEvent ^. #eventId) (-1) + managerStreamName = StreamName "pm:counter-order-1" + insertConcurrentManager = do + callNo <- atomicModifyIORef' insertCount (\n -> (n + 1, n)) + when (callNo == 0) $ appendCounterEventWithId _storeHandle managerStreamName managerId (CounterAdded 9) + options = + defaultRunCommandOptions + & #beforeAppend + .~ insertConcurrentManager + & #retryBackoffMicros + .~ 0 + result <- + _runner $ + runProcessManagerOnce options counterProcessManager sourceEvent (CounterAdded 9) + case result of + Right (Right pmResult) -> do + pmResult ^. #managerResult `shouldSatisfy` \case + PMStateDuplicate duplicateId -> duplicateId == managerId + _ -> False + pmResult ^. #commandResults `shouldSatisfy` \case + [PMCommandAppended {}] -> True + _ -> False + other -> expectationFailure ("expected duplicate manager-state fold, got " <> show other) + + describe "Keiro.ProcessManager duplicate confirmation" $ around (withFreshResourceStore fixture) $ do + it "rejects a duplicate report carrying a different id" $ \(_storeHandle, StoreRunner _runner) -> do + let targetStreamName = StreamName "duplicate-confirmation-mismatch" + ourId = EventId sampleUuid + otherId = EventId sampleUuid2 + appendCounterEventWithId _storeHandle targetStreamName otherId (CounterAdded 1) + outcome <- + _runner $ + confirmBenignDuplicate + targetStreamName + ourId + (StoreFailed (Store.DuplicateEvent (Just otherId))) + outcome `shouldBe` Right False + + it "rejects a matching id that exists only in another stream" $ \(_storeHandle, StoreRunner _runner) -> do + let targetStreamName = StreamName "duplicate-confirmation-target" + otherStreamName = StreamName "duplicate-confirmation-other" + ourId = EventId sampleUuid + targetEventId = EventId sampleUuid2 + appendCounterEventWithId _storeHandle targetStreamName targetEventId (CounterAdded 1) + appendCounterEventWithId _storeHandle otherStreamName ourId (CounterAdded 1) + outcome <- + _runner $ + confirmBenignDuplicate + targetStreamName + ourId + (StoreFailed (Store.DuplicateEvent (Just ourId))) + outcome `shouldBe` Right False + + it "confirms matching and id-less duplicate reports when the id is in the target stream" $ \(_storeHandle, StoreRunner _runner) -> do + let targetStreamName = StreamName "duplicate-confirmation-present" + ourId = EventId sampleUuid + appendCounterEventWithId _storeHandle targetStreamName ourId (CounterAdded 1) + matchingOutcome <- + _runner $ + confirmBenignDuplicate + targetStreamName + ourId + (StoreFailed (Store.DuplicateEvent (Just ourId))) + missingDetailOutcome <- + _runner $ + confirmBenignDuplicate + targetStreamName + ourId + (StoreFailed (Store.DuplicateEvent Nothing)) + matchingOutcome `shouldBe` Right True + missingDetailOutcome `shouldBe` Right True + + it "rejects non-duplicate command failures" $ \(_storeHandle, StoreRunner _runner) -> do + let targetStreamName = StreamName "duplicate-confirmation-non-duplicate" + ourId = EventId sampleUuid + appendCounterEventWithId _storeHandle targetStreamName ourId (CounterAdded 1) + outcome <- + _runner $ + confirmBenignDuplicate + targetStreamName + ourId + (StoreFailed (Store.ConnectionLost "boom")) + outcome `shouldBe` Right False + + describe "Keiro.ProcessManager snapshots" $ around (withFreshResourceStore fixture) $ do + it "writes a snapshot of the manager state stream after the policy threshold" $ \(_storeHandle, StoreRunner _runner) -> do + -- Two distinct source events, both correlating to "order-1", drive the one + -- manager instance to manager-stream version 2, which Every 2 snapshots. + let sourceA = recordedFromEventId (EventId sampleUuid) (CounterAdded 2) + sourceB = recordedFromEventId (EventId sampleUuid2) (CounterAdded 3) + Right (Right _) <- + _runner $ + runProcessManagerOnce defaultRunCommandOptions pmSnapshotProcessManager sourceA (CounterAdded 2) + Right (Right _) <- + _runner $ + runProcessManagerOnce defaultRunCommandOptions pmSnapshotProcessManager sourceB (CounterAdded 3) + Right managerEvents <- + _runner $ + Store.readStreamForward (StreamName "pm:counter-snap-order-1") (StreamVersion 0) 10 + Vector.length managerEvents `shouldBe` 2 + Right snapshotVersion <- + _runner $ + Store.runTransaction $ + Tx.statement "pm:counter-snap-order-1" snapshotVersionForStreamStmt + snapshotVersion `shouldBe` Just (StreamVersion 2) + + it "hydrates the manager from its snapshot and replays only the tail" $ \(_storeHandle, StoreRunner _runner) -> do + -- After the threshold snapshot exists, a third reaction should land on top of + -- the snapshot at version 3 rather than replaying from version 0. + let sourceA = recordedFromEventId (EventId sampleUuid) (CounterAdded 2) + sourceB = recordedFromEventId (EventId sampleUuid2) (CounterAdded 3) + sourceC = recordedFromEventId (EventId sampleUuid3) (CounterAdded 4) + Right (Right _) <- + _runner $ + runProcessManagerOnce defaultRunCommandOptions pmSnapshotProcessManager sourceA (CounterAdded 2) + Right (Right _) <- + _runner $ + runProcessManagerOnce defaultRunCommandOptions pmSnapshotProcessManager sourceB (CounterAdded 3) + -- Confirm the snapshot is present before the tail-replay reaction. + Right snapshotVersion <- + _runner $ + Store.runTransaction $ + Tx.statement "pm:counter-snap-order-1" snapshotVersionForStreamStmt + snapshotVersion `shouldBe` Just (StreamVersion 2) + result <- + _runner $ + runProcessManagerOnce defaultRunCommandOptions pmSnapshotProcessManager sourceC (CounterAdded 4) + case result of + Right (Right pmResult) -> + case pmResult ^. #managerResult of + PMStateAppended managerResult -> + managerResult ^. #streamVersion `shouldBe` StreamVersion 3 + other -> expectationFailure ("expected appended manager state, got " <> show other) + other -> expectationFailure ("expected snapshot-assisted PM reaction, got " <> show other) + + describe "Keiro.Router" $ around (withFreshResourceStore fixture) $ do + it "encodes colon-bearing and non-ASCII id components without collisions" $ \(_storeHandle, StoreRunner _runner) -> do + let sourceEventId = EventId sampleUuid + colonLeft = + deterministicRouterCommandId + "router:a" + "key" + sourceEventId + (StreamName "target") + 0 + colonRight = + deterministicRouterCommandId + "router" + "a:key" + sourceEventId + (StreamName "target") + 0 + unicodeLeft = + deterministicRouterCommandId + "router" + "key" + sourceEventId + (StreamName ("target-" <> Text.singleton '\x101')) + 0 + unicodeRight = + deterministicRouterCommandId + "router" + "key" + sourceEventId + (StreamName ("target-" <> Text.singleton '\x201')) + 0 + colonLeft `shouldNotBe` colonRight + unicodeLeft `shouldNotBe` unicodeRight + + it "resolves targets effectfully and fans out one command per target" $ \(_storeHandle, StoreRunner _runner) -> do + Right () <- + _runner $ + initializeRegisteredReadModel routerTargetsReadModel initializeRouterTargetsTable + Right () <- _runner $ + Store.runTransaction $ do + Tx.statement ("g1", "router-target-a") insertRouterTargetStmt + Tx.statement ("g1", "router-target-b") insertRouterTargetStmt + Tx.statement ("g1", "router-target-c") insertRouterTargetStmt + let sourceEvent = recordedFromEventId (EventId sampleUuid) (CounterAdded 1) + Right (RouterResult rs1) <- + _runner $ + runRouterOnce defaultRunCommandOptions demoRouter sourceEvent (RouteGroup "g1") + length rs1 `shouldBe` 3 + rs1 `shouldSatisfy` all isAppended + -- Data-dependence is load-bearing: an unseeded group resolves to no + -- targets, so the count tracks the read model, not a fixed list. + Right (RouterResult rsEmpty) <- + _runner $ + runRouterOnce defaultRunCommandOptions demoRouter sourceEvent (RouteGroup "no-such-group") + length rsEmpty `shouldBe` 0 + -- Each resolved target stream received exactly one command. + Right targetA <- + _runner $ + Store.readStreamForward (StreamName "router-target-a") (StreamVersion 0) 10 + Right targetB <- + _runner $ + Store.readStreamForward (StreamName "router-target-b") (StreamVersion 0) 10 + Right targetC <- + _runner $ + Store.readStreamForward (StreamName "router-target-c") (StreamVersion 0) 10 + Vector.length targetA `shouldBe` 1 + Vector.length targetB `shouldBe` 1 + Vector.length targetC `shouldBe` 1 + + it "reports every dispatch as a duplicate on replay, writing no new events" $ \(_storeHandle, StoreRunner _runner) -> do + Right () <- + _runner $ + initializeRegisteredReadModel routerTargetsReadModel initializeRouterTargetsTable + Right () <- _runner $ + Store.runTransaction $ do + Tx.statement ("g1", "router-target-a") insertRouterTargetStmt + Tx.statement ("g1", "router-target-b") insertRouterTargetStmt + Tx.statement ("g1", "router-target-c") insertRouterTargetStmt + let sourceEvent = recordedFromEventId (EventId sampleUuid) (CounterAdded 1) + Right (RouterResult rs1) <- + _runner $ + runRouterOnce defaultRunCommandOptions demoRouter sourceEvent (RouteGroup "g1") + rs1 `shouldSatisfy` all isAppended + Right (RouterResult rs2) <- + _runner $ + runRouterOnce defaultRunCommandOptions demoRouter sourceEvent (RouteGroup "g1") + length rs2 `shouldBe` 3 + rs2 `shouldSatisfy` all isDuplicate + -- Replay added nothing: each target stream still holds exactly one event. + Right targetA <- + _runner $ + Store.readStreamForward (StreamName "router-target-a") (StreamVersion 0) 10 + Right targetB <- + _runner $ + Store.readStreamForward (StreamName "router-target-b") (StreamVersion 0) 10 + Right targetC <- + _runner $ + Store.readStreamForward (StreamName "router-target-c") (StreamVersion 0) 10 + Vector.length targetA `shouldBe` 1 + Vector.length targetB `shouldBe` 1 + Vector.length targetC `shouldBe` 1 + + it "dedups by target identity when a redelivered resolve reorders targets after a partial dispatch" $ \(_storeHandle, StoreRunner _runner) -> do + attemptsRef <- newIORef (0 :: Int) + let sourceEvent = recordedFromEventId (EventId sampleUuid) (CounterAdded 1) + router = unstableRouter attemptsRef $ \case + 0 -> ["swap-a"] + _ -> ["swap-b", "swap-a"] + Right (RouterResult firstAttempt) <- + _runner $ + runRouterOnce defaultRunCommandOptions router sourceEvent (RouteGroup "g1") + firstAttempt `shouldSatisfy` all isAppended + Right (RouterResult secondAttempt) <- + _runner $ + runRouterOnce defaultRunCommandOptions router sourceEvent (RouteGroup "g1") + secondAttempt `shouldSatisfy` \case + [swapB, swapA] -> isAppended swapB && isDuplicate swapA + _ -> False + Right swapAEvents <- + _runner $ + Store.readStreamForward (StreamName "swap-a") (StreamVersion 0) 10 + Right swapBEvents <- + _runner $ + Store.readStreamForward (StreamName "swap-b") (StreamVersion 0) 10 + Vector.length swapAEvents `shouldBe` 1 + Vector.length swapBEvents `shouldBe` 1 + + it "dispatches a target added by resolve drift instead of misreading it as a duplicate" $ \(_storeHandle, StoreRunner _runner) -> do + attemptsRef <- newIORef (0 :: Int) + let sourceEvent = recordedFromEventId (EventId sampleUuid) (CounterAdded 1) + router = unstableRouter attemptsRef $ \case + 0 -> ["growth-a", "growth-b"] + _ -> ["growth-a", "growth-c"] + Right (RouterResult firstAttempt) <- + _runner $ + runRouterOnce defaultRunCommandOptions router sourceEvent (RouteGroup "g1") + firstAttempt `shouldSatisfy` all isAppended + Right (RouterResult secondAttempt) <- + _runner $ + runRouterOnce defaultRunCommandOptions router sourceEvent (RouteGroup "g1") + secondAttempt `shouldSatisfy` \case + [growthA, growthC] -> isDuplicate growthA && isAppended growthC + _ -> False + Right growthAEvents <- + _runner $ + Store.readStreamForward (StreamName "growth-a") (StreamVersion 0) 10 + Right growthBEvents <- + _runner $ + Store.readStreamForward (StreamName "growth-b") (StreamVersion 0) 10 + Right growthCEvents <- + _runner $ + Store.readStreamForward (StreamName "growth-c") (StreamVersion 0) 10 + Vector.length growthAEvents `shouldBe` 1 + Vector.length growthBEvents `shouldBe` 1 + Vector.length growthCEvents `shouldBe` 1 + + it "keeps full-completion order swaps idempotent" $ \(_storeHandle, StoreRunner _runner) -> do + attemptsRef <- newIORef (0 :: Int) + let sourceEvent = recordedFromEventId (EventId sampleUuid) (CounterAdded 1) + router = unstableRouter attemptsRef $ \case + 0 -> ["order-a", "order-b"] + _ -> ["order-b", "order-a"] + Right (RouterResult firstAttempt) <- + _runner $ + runRouterOnce defaultRunCommandOptions router sourceEvent (RouteGroup "g1") + firstAttempt `shouldSatisfy` all isAppended + Right (RouterResult secondAttempt) <- + _runner $ + runRouterOnce defaultRunCommandOptions router sourceEvent (RouteGroup "g1") + secondAttempt `shouldSatisfy` all isDuplicate + Right orderAEvents <- + _runner $ + Store.readStreamForward (StreamName "order-a") (StreamVersion 0) 10 + Right orderBEvents <- + _runner $ + Store.readStreamForward (StreamName "order-b") (StreamVersion 0) 10 + Vector.length orderAEvents `shouldBe` 1 + Vector.length orderBEvents `shouldBe` 1 + + it "keeps dispatches to targets dropped by a later resolve attempt" $ \(_storeHandle, StoreRunner _runner) -> do + attemptsRef <- newIORef (0 :: Int) + let sourceEvent = recordedFromEventId (EventId sampleUuid) (CounterAdded 1) + router = unstableRouter attemptsRef $ \case + 0 -> ["drop-a", "drop-b"] + _ -> ["drop-b"] + Right (RouterResult firstAttempt) <- + _runner $ + runRouterOnce defaultRunCommandOptions router sourceEvent (RouteGroup "g1") + firstAttempt `shouldSatisfy` all isAppended + Right (RouterResult secondAttempt) <- + _runner $ + runRouterOnce defaultRunCommandOptions router sourceEvent (RouteGroup "g1") + secondAttempt `shouldSatisfy` \case + [dropB] -> isDuplicate dropB + _ -> False + -- Resolve is authoritative per attempt. Across redeliveries, the + -- dispatched set is the union of each attempt's resolved targets. + Right dropAEvents <- + _runner $ + Store.readStreamForward (StreamName "drop-a") (StreamVersion 0) 10 + Right dropBEvents <- + _runner $ + Store.readStreamForward (StreamName "drop-b") (StreamVersion 0) 10 + Vector.length dropAEvents `shouldBe` 1 + Vector.length dropBEvents `shouldBe` 1 + + it "keeps repeated commands to one target distinct within a resolve batch" $ \(_storeHandle, StoreRunner _runner) -> do + attemptsRef <- newIORef (0 :: Int) + let sourceEvent = recordedFromEventId (EventId sampleUuid) (CounterAdded 1) + router = unstableRouter attemptsRef (const ["twin", "twin"]) + Right (RouterResult firstAttempt) <- + _runner $ + runRouterOnce defaultRunCommandOptions router sourceEvent (RouteGroup "g1") + firstAttempt `shouldSatisfy` all isAppended + Right twinEventsAfterFirstAttempt <- + _runner $ + Store.readStreamForward (StreamName "twin") (StreamVersion 0) 10 + Vector.length twinEventsAfterFirstAttempt `shouldBe` 2 + Right (RouterResult secondAttempt) <- + _runner $ + runRouterOnce defaultRunCommandOptions router sourceEvent (RouteGroup "g1") + secondAttempt `shouldSatisfy` all isDuplicate + Right twinEventsAfterSecondAttempt <- + _runner $ + Store.readStreamForward (StreamName "twin") (StreamVersion 0) 10 + Vector.length twinEventsAfterSecondAttempt `shouldBe` 2 + + it "drains an adapter, dispatching one command per resolved target for every message" $ \(_storeHandle, StoreRunner _runner) -> do + Right () <- + _runner $ + initializeRegisteredReadModel routerTargetsReadModel initializeRouterTargetsTable + Right () <- _runner $ + Store.runTransaction $ do + Tx.statement ("g1", "worker-a") insertRouterTargetStmt + Tx.statement ("g1", "worker-b") insertRouterTargetStmt + Tx.statement ("g2", "worker-c") insertRouterTargetStmt + decisionsRef <- newIORef [] + let sourceEvent1 = recordedFromEventId (EventId sampleUuid) (CounterAdded 1) + sourceEvent2 = recordedFromEventId (EventId sampleUuid2) (CounterAdded 1) + messages = + [ (sourceEvent1, RouteGroup "g1"), + (sourceEvent2, RouteGroup "g2") + ] + adapter = inMemoryAdapter decisionsRef messages + Right () <- + _runner $ + runRouterWorker defaultRunCommandOptions demoRouter adapter Just + decisions <- readIORef decisionsRef + decisions `shouldBe` [AckOk, AckOk] + Right wa <- + _runner $ + Store.readStreamForward (StreamName "worker-a") (StreamVersion 0) 10 + Right wb <- + _runner $ + Store.readStreamForward (StreamName "worker-b") (StreamVersion 0) 10 + Right wc <- + _runner $ + Store.readStreamForward (StreamName "worker-c") (StreamVersion 0) 10 + Vector.length wa `shouldBe` 1 + Vector.length wb `shouldBe` 1 + Vector.length wc `shouldBe` 1 + + it "finalizes AckHalt rather than AckOk when a dispatched command fails" $ \(_storeHandle, StoreRunner _runner) -> do + decisionsRef <- newIORef [] + let sourceEvent = recordedFromEventId (EventId sampleUuid) (CounterAdded 1) + messages = [(sourceEvent, RouteGroup "g1")] + adapter = inMemoryAdapter decisionsRef messages + Right () <- + _runner $ + runRouterWorker defaultRunCommandOptions failingRouter adapter Just + decisions <- readIORef decisionsRef + decisions `shouldSatisfy` \case + [AckHalt (HaltFatal _)] -> True + _ -> False + + it "dead-letters a rejected router dispatch and acknowledges the source event" $ \(_storeHandle, StoreRunner _runner) -> do + decisionsRef <- newIORef [] + let sourceEvent = recordedFromEventId (EventId sampleUuid) (CounterAdded 1) + adapter = inMemoryAdapter decisionsRef [(sourceEvent, RouteGroup "g1")] + workerOptions = defaultWorkerOptions & #rejectedCommandPolicy .~ RejectedDeadLetter + Right () <- + _runner $ + runRouterWorkerWith workerOptions defaultRunCommandOptions failingRouter adapter Just + readIORef decisionsRef `shouldReturn` [AckOk] + Right deadLetters <- _runner (listDispatchDeadLetters "failing-router") + case deadLetters of + [row] -> do + row ^. #dispatcherKind `shouldBe` DispatcherRouter + row ^. #correlationId `shouldBe` "g1" + row ^. #targetStreamName `shouldBe` StreamName "failing-target" + row ^. #errorClass `shouldBe` "command_rejected" + other -> expectationFailure ("expected one router dead letter, got " <> show other) + + it "finalizes AckRetry for a transient thrown resolver error and continues" $ \(_storeHandle, StoreRunner _runner) -> do + Right () <- + _runner $ + initializeRegisteredReadModel routerTargetsReadModel initializeRouterTargetsTable + Right () <- + _runner $ + Store.runTransaction (Tx.statement ("g2", "worker-after-retry") insertRouterTargetStmt) + decisionsRef <- newIORef [] + attemptsRef <- newIORef (0 :: Int) + let sourceEvent1 = recordedFromEventId (EventId sampleUuid) (CounterAdded 1) + sourceEvent2 = recordedFromEventId (EventId sampleUuid2) (CounterAdded 1) + messages = [(sourceEvent1, RouteGroup "g1"), (sourceEvent2, RouteGroup "g2")] + adapter = inMemoryAdapter decisionsRef messages + flakyRouter :: + (IOE :> es, Store :> es, Error Store.StoreError :> es) => + Router RouteGroup (HsPred '[] CounterCommand) '[] CounterState CounterCommand CounterEvent es + flakyRouter = + Router + { name = "flaky-router", + key = \(RouteGroup g) -> g, + resolve = \(RouteGroup g) -> do + attempt <- liftIO (atomicModifyIORef' attemptsRef (\n -> (n + 1, n))) + if attempt == 0 + then throwError (Store.ConnectionLost "injected") + else do + result <- runQuery Nothing routerTargetsReadModel g + pure $ case result of + Right targetIds -> + [ PMCommand {target = stream targetId, command = Add 1} + | targetId <- targetIds + ] + Left _ -> [], + targetEventStream = counterEventStream, + targetProjections = const [] + } + Right () <- + _runner $ + runRouterWorker defaultRunCommandOptions flakyRouter adapter Just + decisions <- readIORef decisionsRef + decisions `shouldSatisfy` \case + [AckRetry {}, AckOk] -> True + _ -> False + + it "finalizes AckHalt for a deterministic thrown resolver error" $ \(_storeHandle, StoreRunner _runner) -> do + decisionsRef <- newIORef [] + let sourceEvent = recordedFromEventId (EventId sampleUuid) (CounterAdded 1) + messages = [(sourceEvent, RouteGroup "g1")] + adapter = inMemoryAdapter decisionsRef messages + failingResolveRouter :: + (Error Store.StoreError :> es) => + Router RouteGroup (HsPred '[] CounterCommand) '[] CounterState CounterCommand CounterEvent es + failingResolveRouter = + Router + { name = "failing-resolve-router", + key = \(RouteGroup g) -> g, + resolve = \_ -> throwError (Store.UnexpectedServerError "XX000" "boom"), + targetEventStream = counterEventStream, + targetProjections = const [] + } + Right () <- + _runner $ + runRouterWorker defaultRunCommandOptions failingResolveRouter adapter Just + decisions <- readIORef decisionsRef + decisions `shouldSatisfy` \case + [AckHalt (HaltFatal _)] -> True + _ -> False + + it "folds a concurrent duplicate router dispatch to PMCommandDuplicate" $ \(_storeHandle, StoreRunner _runner) -> do + Right () <- + _runner $ + initializeRegisteredReadModel routerTargetsReadModel initializeRouterTargetsTable + Right () <- + _runner $ + Store.runTransaction (Tx.statement ("g1", "router-duplicate-target") insertRouterTargetStmt) + insertCount <- newIORef (0 :: Int) + let sourceEvent = recordedFromEventId (EventId sampleUuid) (CounterAdded 1) + targetStreamName = StreamName "router-duplicate-target" + commandId = + deterministicRouterCommandId + "demo-router" + "g1" + (sourceEvent ^. #eventId) + targetStreamName + 0 + insertConcurrentTarget = do + callNo <- atomicModifyIORef' insertCount (\n -> (n + 1, n)) + when (callNo == 0) $ appendCounterEventWithId _storeHandle targetStreamName commandId (CounterAdded 1) + options = + defaultRunCommandOptions + & #beforeAppend + .~ insertConcurrentTarget + & #retryBackoffMicros + .~ 0 + result <- + _runner $ + runRouterOnce options demoRouter sourceEvent (RouteGroup "g1") + case result of + Right (RouterResult [PMCommandDuplicate duplicateId]) -> + duplicateId `shouldBe` commandId + other -> expectationFailure ("expected duplicate router dispatch fold, got " <> show other) + Right targetEvents <- + _runner $ + Store.readStreamForward targetStreamName (StreamVersion 0) 10 + Vector.length targetEvents `shouldBe` 1 + + it "dedups a pre-upgrade positional router dispatch during the transition" $ \(_storeHandle, StoreRunner _runner) -> do + Right () <- + _runner $ + initializeRegisteredReadModel routerTargetsReadModel initializeRouterTargetsTable + Right () <- + _runner $ + Store.runTransaction (Tx.statement ("g1", "transition-target") insertRouterTargetStmt) + let sourceEvent = recordedFromEventId (EventId sampleUuid) (CounterAdded 1) + legacyId = deterministicCommandId "demo-router" "g1" (sourceEvent ^. #eventId) 0 + targetStreamName = StreamName "transition-target" + appendCounterEventWithId _storeHandle targetStreamName legacyId (CounterAdded 1) + result <- + _runner $ + runRouterOnce defaultRunCommandOptions demoRouter sourceEvent (RouteGroup "g1") + case result of + Right (RouterResult [PMCommandDuplicate duplicateId]) -> + duplicateId `shouldBe` legacyId + other -> expectationFailure ("expected transition duplicate, got " <> show other) + Right targetEvents <- + _runner $ + Store.readStreamForward targetStreamName (StreamVersion 0) 10 + Vector.length targetEvents `shouldBe` 1 + + describe "Keiro.Timer" $ around (withFreshStore fixture) $ do + it "validates worker options before startup" $ \_storeHandle -> do + shouldBeRight_ (mkTimerWorkerOptions defaultTimerWorkerOptions) + mkTimerWorkerOptions (defaultTimerWorkerOptions & #maxAttempts ?~ (-1)) + `shouldBeLeft` InvalidTimerMaxAttempts (-1) + mkTimerWorkerOptions (defaultTimerWorkerOptions & #requeueStuckAfter ?~ 0) + `shouldBeLeft` InvalidTimerRequeueStuckAfter 0 + + it "claims a due timer, fires a command, and marks it complete once" $ \storeHandle -> do + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + scheduleTimerTx counterTimerRequest + let firedEventId = EventId sampleUuid2 + workerResult <- Store.runStoreIO storeHandle $ + runTimerWorker Nothing dueTimerTime $ \_ -> do + fired <- + runCommand + (defaultRunCommandOptions & #eventIds .~ [firedEventId]) + counterEventStream + (stream "timer-target") + (Add 11) + case fired of + Right _ -> pure (Just firedEventId) + Left err -> liftIO (expectationFailure ("expected timer command to fire, got " <> show err)) *> pure Nothing + case workerResult of + Right (Just timer) -> + timer ^. #status `shouldBe` Firing + other -> expectationFailure ("expected fired timer, got " <> show other) + secondWorkerResult <- + Store.runStoreIO storeHandle $ + runTimerWorker Nothing dueTimerTime (\_ -> pure (Just firedEventId)) + secondWorkerResult `shouldBe` Right Nothing + Right targetEvents <- + Store.runStoreIO storeHandle $ + Store.readStreamForward (StreamName "timer-target") (StreamVersion 0) 10 + fmap (^. #eventId) (Vector.toList targetEvents) `shouldBe` [firedEventId] + + it "records timer backlog, fire lag, attempts, and stuck count" $ \storeHandle -> do + (exporter, metricsRef) <- inMemoryMetricExporter + (provider, _env) <- + createMeterProvider + emptyMaterializedResources + defaultSdkMeterProviderOptions {metricExporter = Just exporter} + meter <- getMeter provider Telemetry.keiroInstrumentationLibrary + keiroMetrics <- Telemetry.newKeiroMetrics meter + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + scheduleTimerTx counterTimerRequest + let firedEventId = EventId sampleUuid2 + workerResult <- + Store.runStoreIO storeHandle $ + runTimerWorker (Just keiroMetrics) dueTimerTime (\_ -> pure (Just firedEventId)) + case workerResult of + Right (Just _) -> pure () + other -> expectationFailure ("expected a fired timer, got " <> show other) + _ <- forceFlushMeterProvider provider Nothing + exported <- readIORef metricsRef + let scalars = flattenScalarPoints exported + hists = flattenHistogramPoints exported + -- One scheduled+due row at the start of the pass: backlog gauge holds 1. + lookup "keiro.timer.backlog" scalars `shouldBe` Just (IntNumber 1) + -- Nothing was stranded in 'firing' before this pass: stuck gauge holds 0. + lookup "keiro.timer.stuck" scalars `shouldBe` Just (IntNumber 0) + -- The claimed timer was due exactly at 'now' and is on its first attempt: + -- one fire.lag observation of 0 ms and one attempts observation of 1. + [(c, s) | (n, c, s) <- hists, n == "keiro.timer.fire.lag"] `shouldBe` [(1, 0.0)] + [(c, s) | (n, c, s) <- hists, n == "keiro.timer.attempts"] `shouldBe` [(1, 1.0)] + + it "finds a firing timer with findStuckTimers and requeues it for re-firing" $ \storeHandle -> do + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + scheduleTimerTx counterTimerRequest + -- Strand it in Firing by claiming without firing. + claimed <- Store.runStoreIO storeHandle $ claimDueTimer dueTimerTime + case claimed of + Right (Just timer) -> timer ^. #status `shouldBe` Firing + other -> expectationFailure ("expected a claimed timer, got " <> show other) + -- It surfaces as stuck under the permissive filter. + Right stuck <- + Store.runStoreIO storeHandle $ + findStuckTimers dueTimerTime anyStuckTimer + fmap (^. #timerId) stuck `shouldBe` [counterTimerRequest ^. #timerId] + -- A bound it does not meet (only one attempt) excludes it. + Right unmatched <- + Store.runStoreIO storeHandle $ + findStuckTimers dueTimerTime (StuckTimerFilter Nothing (Just 5)) + unmatched `shouldBe` [] + -- Requeue is idempotent: True the first time, False once it is scheduled. + requeued <- + Store.runStoreIO storeHandle $ + requeueStuckTimer (counterTimerRequest ^. #timerId) + requeued `shouldBe` Right True + requeuedAgain <- + Store.runStoreIO storeHandle $ + requeueStuckTimer (counterTimerRequest ^. #timerId) + requeuedAgain `shouldBe` Right False + -- The ordinary loop re-claims and fires it exactly once. + let firedEventId = EventId sampleUuid2 + workerResult <- Store.runStoreIO storeHandle $ + runTimerWorker Nothing dueTimerTime $ \_ -> do + fired <- + runCommand + (defaultRunCommandOptions & #eventIds .~ [firedEventId]) + counterEventStream + (stream "timer-target") + (Add 7) + case fired of + Right _ -> pure (Just firedEventId) + Left err -> liftIO (expectationFailure ("expected timer command to fire, got " <> show err)) *> pure Nothing + case workerResult of + Right (Just timer) -> + timer ^. #status `shouldBe` Firing + other -> expectationFailure ("expected re-fired timer, got " <> show other) + secondWorkerResult <- + Store.runStoreIO storeHandle $ + runTimerWorker Nothing dueTimerTime (\_ -> pure (Just firedEventId)) + secondWorkerResult `shouldBe` Right Nothing + Right targetEvents <- + Store.runStoreIO storeHandle $ + Store.readStreamForward (StreamName "timer-target") (StreamVersion 0) 10 + fmap (^. #eventId) (Vector.toList targetEvents) `shouldBe` [firedEventId] + + it "re-fires a timer stranded by a crashed worker" $ \storeHandle -> do + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + scheduleTimerTx counterTimerRequest + Right (Just claimed) <- Store.runStoreIO storeHandle $ claimDueTimer dueTimerTime + claimed ^. #status `shouldBe` Firing + realNow <- getCurrentTime + firedRef <- newIORef [] + let futureNow = addUTCTime 400 realNow + firedEventId = EventId sampleUuid2 + workerResult <- + Store.runStoreIO storeHandle $ + runTimerWorker Nothing futureNow $ \timer -> do + liftIO (modifyIORef' firedRef (<> [timer ^. #timerId])) + pure (Just firedEventId) + case workerResult of + Right (Just timer) -> timer ^. #timerId `shouldBe` counterTimerRequest ^. #timerId + other -> expectationFailure ("expected stale timer to be requeued and claimed, got " <> show other) + firedTimers <- readIORef firedRef + firedTimers `shouldBe` [counterTimerRequest ^. #timerId] + Right statusRow <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + Tx.statement sampleUuid timerStatusAndErrorStmt + statusRow `shouldBe` Just ("fired", Nothing) + secondWorkerResult <- + Store.runStoreIO storeHandle $ + runTimerWorker Nothing futureNow (\_ -> pure (Just firedEventId)) + secondWorkerResult `shouldBe` Right Nothing + + it "does not requeue a fresh firing row" $ \storeHandle -> do + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + scheduleTimerTx counterTimerRequest + Right (Just _) <- Store.runStoreIO storeHandle $ claimDueTimer dueTimerTime + realNow <- getCurrentTime + firedRef <- newIORef False + workerResult <- + Store.runStoreIO storeHandle $ + runTimerWorker Nothing realNow $ \_ -> do + liftIO (writeIORef firedRef True) + pure (Just (EventId sampleUuid2)) + workerResult `shouldBe` Right Nothing + didFire <- readIORef firedRef + didFire `shouldBe` False + Right statusRow <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + Tx.statement sampleUuid timerStatusAndErrorStmt + statusRow `shouldBe` Just ("firing", Nothing) + + it "requeueStuckAfter = Nothing preserves a stranded firing row" $ \storeHandle -> do + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + scheduleTimerTx counterTimerRequest + Right (Just _) <- Store.runStoreIO storeHandle $ claimDueTimer dueTimerTime + realNow <- getCurrentTime + firedRef <- newIORef False + let opts = defaultTimerWorkerOptions & #requeueStuckAfter .~ Nothing + workerResult <- + Store.runStoreIO storeHandle $ + runTimerWorkerWith Nothing opts (addUTCTime 400 realNow) $ \_ -> do + liftIO (writeIORef firedRef True) + pure (Just (EventId sampleUuid2)) + workerResult `shouldBe` Right Nothing + didFire <- readIORef firedRef + didFire `shouldBe` False + Right statusRow <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + Tx.statement sampleUuid timerStatusAndErrorStmt + statusRow `shouldBe` Just ("firing", Nothing) + + it "does not claim a cancelled timer" $ \storeHandle -> do + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + scheduleTimerTx counterTimerRequest + cancelled <- + Store.runStoreIO storeHandle $ + cancelTimer (counterTimerRequest ^. #timerId) + cancelled `shouldBe` Right True + claimed <- Store.runStoreIO storeHandle $ claimDueTimer dueTimerTime + claimed `shouldBe` Right Nothing + cancelledAgain <- + Store.runStoreIO storeHandle $ + cancelTimer (counterTimerRequest ^. #timerId) + cancelledAgain `shouldBe` Right False + + it "dead-letters a timer that exceeds the attempt ceiling and never reclaims it" $ \storeHandle -> do + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + scheduleTimerTx counterTimerRequest + firedRef <- newIORef False + let firedEventId = EventId sampleUuid2 + -- maxAttempts = Just 0: the first claim sets attempts = 1 > 0, so the + -- worker dead-letters instead of firing. + result <- Store.runStoreIO storeHandle $ + runTimerWorkerWith Nothing (defaultTimerWorkerOptions & #maxAttempts .~ Just 0) dueTimerTime $ \_ -> do + liftIO (writeIORef firedRef True) + pure (Just firedEventId) + case result of + Right (Just timer) -> + timer ^. #status `shouldBe` Firing + other -> expectationFailure ("expected a claimed timer, got " <> show other) + -- The fire action never ran. + didFire <- readIORef firedRef + didFire `shouldBe` False + -- The row landed in 'dead' with the expected reason in last_error. + Right statusRow <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + Tx.statement sampleUuid timerStatusAndErrorStmt + statusRow `shouldBe` Just ("dead", Just "timer exceeded attempt ceiling of 0") + -- A dead row is never re-claimed. + secondWorkerResult <- + Store.runStoreIO storeHandle $ + runTimerWorker Nothing dueTimerTime (\_ -> pure (Just firedEventId)) + secondWorkerResult `shouldBe` Right Nothing + + it "markTimerFired does not resurrect a dead timer" $ \storeHandle -> do + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + scheduleTimerTx counterTimerRequest + Right (Just _) <- Store.runStoreIO storeHandle $ claimDueTimer dueTimerTime + deadened <- + Store.runStoreIO storeHandle $ + deadLetterTimer (counterTimerRequest ^. #timerId) "operator dead-letter" + deadened `shouldBe` Right True + marked <- + Store.runStoreIO storeHandle $ + markTimerFired (counterTimerRequest ^. #timerId) (EventId sampleUuid2) + marked `shouldBe` Right False + Right statusRow <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + Tx.statement sampleUuid timerStatusAndErrorStmt + statusRow `shouldBe` Just ("dead", Just "operator dead-letter") + + it "records a row stranded in Firing in the stuck gauge" $ \storeHandle -> do + (exporter, metricsRef) <- inMemoryMetricExporter + (provider, _env) <- + createMeterProvider + emptyMaterializedResources + defaultSdkMeterProviderOptions {metricExporter = Just exporter} + meter <- getMeter provider Telemetry.keiroInstrumentationLibrary + keiroMetrics <- Telemetry.newKeiroMetrics meter + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + scheduleTimerTx counterTimerRequest + -- Strand it in Firing by claiming without firing (a crashed worker). + Right (Just _) <- Store.runStoreIO storeHandle $ claimDueTimer dueTimerTime + -- A later pass finds nothing scheduled and due, but sees the stranded row. + workerResult <- + Store.runStoreIO storeHandle $ + runTimerWorker (Just keiroMetrics) dueTimerTime (\_ -> pure Nothing) + workerResult `shouldBe` Right Nothing + _ <- forceFlushMeterProvider provider Nothing + exported <- readIORef metricsRef + let scalars = flattenScalarPoints exported + -- The one firing row is counted as stuck. + lookup "keiro.timer.stuck" scalars `shouldBe` Just (IntNumber 1) + -- It is not 'scheduled', so it does not show up as backlog. + lookup "keiro.timer.backlog" scalars `shouldBe` Just (IntNumber 0) + + describe "Keiro.Outbox.Kafka" $ do + it "converts an outbox row to a Kafka producer record" $ do + let envelope = sampleIntegrationEnvelope + row = sampleOutboxRow envelope + record = OutboxKafka.outboxRowToKafkaRecord row + record ^. #topic `shouldBe` envelope ^. #destination + record ^. #key `shouldBe` Just "order-123" + record ^. #payload `shouldBe` envelope ^. #payloadBytes + -- Headers include identity fields and content type. + let headers = record ^. #headers + messageIdHeader = Prelude.lookup "keiro-message-id" headers + messageIdHeader `shouldBe` Just "018f0f18-17aa-7000-8000-0000000000aa" + + it "drops the partition key when the envelope has no key" $ do + let envelope = sampleIntegrationEnvelope & #key .~ Nothing + record = OutboxKafka.integrationEventToKafkaRecord envelope + record ^. #key `shouldBe` Nothing + + describe "Keiro.Outbox" $ around (withFreshStore fixture) $ do + it "validates publisher options before startup" $ \_storeHandle -> do + shouldBeRight_ (mkOutboxPublishOptions defaultPublishOptions) + mkOutboxPublishOptions (defaultPublishOptions & #batchSize .~ 0) + `shouldBeLeft` InvalidOutboxBatchSize 0 + mkOutboxPublishOptions (defaultPublishOptions & #maxAttempts .~ 0) + `shouldBeLeft` InvalidOutboxMaxAttempts 0 + mkOutboxPublishOptions (defaultPublishOptions & #publishingTimeout .~ 0) + `shouldBeLeft` InvalidOutboxPublishingTimeout 0 + mkOutboxPublishOptions (defaultPublishOptions & #backoff .~ ConstantBackoff (-1)) + `shouldBeLeft` InvalidConstantBackoff (-1) + mkOutboxPublishOptions + ( defaultPublishOptions + & #backoff + .~ ExponentialBackoff + ExponentialBackoffOptions + { initial = 0, + maxDelay = 1, + multiplier = 2 + } + ) + `shouldBeLeft` InvalidExponentialBackoffInitial 0 + mkOutboxPublishOptions + ( defaultPublishOptions + & #backoff + .~ ExponentialBackoff + ExponentialBackoffOptions + { initial = 1, + maxDelay = 10, + multiplier = 0.5 + } + ) + `shouldBeLeft` InvalidExponentialBackoffMultiplier 0.5 + mkOutboxPublishOptions + ( defaultPublishOptions + & #backoff + .~ ExponentialBackoff + ExponentialBackoffOptions + { initial = 5, + maxDelay = 4, + multiplier = 2 + } + ) + `shouldBeLeft` InvalidExponentialBackoffMaxDelay 5 4 + + it "enqueues and looks up an outbox row" $ \storeHandle -> do + let envelope = sampleIntegrationEnvelope + oid = OutboxId outboxUuid1 + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction (enqueueIntegrationEventTx oid envelope) + lookedUp <- Store.runStoreIO storeHandle (lookupOutbox oid) + case lookedUp of + Right (Just row) -> do + row ^. #outboxId `shouldBe` oid + row ^. #status `shouldBe` OutboxPending + row ^. #attemptCount `shouldBe` 0 + row ^. #event . #messageId `shouldBe` envelope ^. #messageId + row ^. #event . #destination `shouldBe` envelope ^. #destination + row ^. #event . #payloadBytes `shouldBe` envelope ^. #payloadBytes + other -> expectationFailure ("expected enqueued row, got " <> show other) + + it "claims a pending row, transitions it to publishing, and increments attempt count" $ \storeHandle -> do + let oid = OutboxId outboxUuid1 + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction (enqueueIntegrationEventTx oid sampleIntegrationEnvelope) + now <- getCurrentTime + Right rows <- Store.runStoreIO storeHandle (claimOutboxBatch PerKeyHeadOfLine 10 now) + case rows of + [row] -> do + row ^. #outboxId `shouldBe` oid + row ^. #status `shouldBe` OutboxPublishing + row ^. #attemptCount `shouldBe` 1 + other -> expectationFailure ("expected one claimed row, got " <> show other) + + it "claims contiguous per-key runs in one pass" $ \storeHandle -> do + let keyedRows = + [ (outboxIdFromOrdinal 1, sampleIntegrationEnvelope & #messageId .~ "run-a1" & #key .~ Just "A"), + (outboxIdFromOrdinal 2, sampleIntegrationEnvelope & #messageId .~ "run-a2" & #key .~ Just "A"), + (outboxIdFromOrdinal 3, sampleIntegrationEnvelope & #messageId .~ "run-a3" & #key .~ Just "A"), + (outboxIdFromOrdinal 4, sampleIntegrationEnvelope & #messageId .~ "run-a4" & #key .~ Just "A"), + (outboxIdFromOrdinal 5, sampleIntegrationEnvelope & #messageId .~ "run-a5" & #key .~ Just "A"), + (outboxIdFromOrdinal 6, sampleIntegrationEnvelope & #messageId .~ "run-b1" & #key .~ Just "B"), + (outboxIdFromOrdinal 7, sampleIntegrationEnvelope & #messageId .~ "run-b2" & #key .~ Just "B"), + (outboxIdFromOrdinal 8, sampleIntegrationEnvelope & #messageId .~ "run-b3" & #key .~ Just "B") + ] + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + traverse_ (uncurry enqueueIntegrationEventTx) keyedRows + now <- getCurrentTime + Right rows <- Store.runStoreIO storeHandle (claimOutboxBatch PerKeyHeadOfLine 10 now) + fmap (^. #outboxId) rows `shouldBe` fmap fst keyedRows + fmap (^. #attemptCount) rows `shouldBe` replicate 8 1 + + it "does not let a backoff head starve other keys" $ \storeHandle -> do + let a1Id = outboxIdFromOrdinal 1 + a2Id = outboxIdFromOrdinal 2 + b1Id = outboxIdFromOrdinal 3 + b2Id = outboxIdFromOrdinal 4 + rows = + [ (a1Id, sampleIntegrationEnvelope & #messageId .~ "backoff-a1" & #key .~ Just "A"), + (a2Id, sampleIntegrationEnvelope & #messageId .~ "backoff-a2" & #key .~ Just "A"), + (b1Id, sampleIntegrationEnvelope & #messageId .~ "backoff-b1" & #key .~ Just "B"), + (b2Id, sampleIntegrationEnvelope & #messageId .~ "backoff-b2" & #key .~ Just "B") + ] + failA1 row + | row ^. #outboxId == a1Id = pure (PublishFailed "wait") + | otherwise = pure PublishSucceeded + opts = + defaultPublishOptions + & #batchSize + .~ 1 + & #backoff + .~ ConstantBackoff 3600 + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + traverse_ (uncurry enqueueIntegrationEventTx) rows + Right failedPass <- Store.runStoreIO storeHandle (publishClaimedOutbox (perRow failA1) opts Nothing) + failedPass ^. #retried `shouldBe` 1 + now <- getCurrentTime + Right claimed <- Store.runStoreIO storeHandle (claimOutboxBatch PerKeyHeadOfLine 10 now) + fmap (^. #outboxId) claimed `shouldBe` [b1Id, b2Id] + Right (Just a2Row) <- Store.runStoreIO storeHandle (lookupOutbox a2Id) + a2Row ^. #status `shouldBe` OutboxPending + + it "claims contiguous per-source runs in one pass" $ \storeHandle -> do + let rows = + [ (outboxIdFromOrdinal 1, sampleIntegrationEnvelope & #messageId .~ "source-a1" & #key .~ Just "A"), + (outboxIdFromOrdinal 2, sampleIntegrationEnvelope & #messageId .~ "source-b1" & #key .~ Just "B"), + (outboxIdFromOrdinal 3, sampleIntegrationEnvelope & #messageId .~ "source-a2" & #key .~ Just "A"), + (outboxIdFromOrdinal 4, sampleIntegrationEnvelope & #messageId .~ "source-b2" & #key .~ Just "B") + ] + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + traverse_ (uncurry enqueueIntegrationEventTx) rows + now <- getCurrentTime + Right claimed <- Store.runStoreIO storeHandle (claimOutboxBatch PerSourceStream 10 now) + fmap (^. #outboxId) claimed `shouldBe` fmap fst rows + + it "claims null-keyed rows freely alongside keyed runs" $ \storeHandle -> do + let rows = + [ (outboxIdFromOrdinal 1, sampleIntegrationEnvelope & #messageId .~ "null-1" & #key .~ Nothing), + (outboxIdFromOrdinal 2, sampleIntegrationEnvelope & #messageId .~ "keyed-1" & #key .~ Just "A"), + (outboxIdFromOrdinal 3, sampleIntegrationEnvelope & #messageId .~ "null-2" & #key .~ Nothing), + (outboxIdFromOrdinal 4, sampleIntegrationEnvelope & #messageId .~ "keyed-2" & #key .~ Just "A") + ] + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + traverse_ (uncurry enqueueIntegrationEventTx) rows + now <- getCurrentTime + Right claimed <- Store.runStoreIO storeHandle (claimOutboxBatch PerKeyHeadOfLine 10 now) + fmap (^. #outboxId) claimed `shouldBe` fmap fst rows + + it "does not claim a tail while the previous run is still publishing" $ \storeHandle -> do + let rows = + [ (outboxIdFromOrdinal 1, sampleIntegrationEnvelope & #messageId .~ "publishing-a1" & #key .~ Just "A"), + (outboxIdFromOrdinal 2, sampleIntegrationEnvelope & #messageId .~ "publishing-a2" & #key .~ Just "A"), + (outboxIdFromOrdinal 3, sampleIntegrationEnvelope & #messageId .~ "publishing-a3" & #key .~ Just "A") + ] + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + traverse_ (uncurry enqueueIntegrationEventTx) rows + now <- getCurrentTime + Right firstClaim <- Store.runStoreIO storeHandle (claimOutboxBatch PerKeyHeadOfLine 10 now) + fmap (^. #outboxId) firstClaim `shouldBe` fmap fst rows + Right secondClaim <- Store.runStoreIO storeHandle (claimOutboxBatch PerKeyHeadOfLine 10 now) + secondClaim `shouldBe` [] + + it "marks a claimed row as sent with published_at set" $ \storeHandle -> do + let oid = OutboxId outboxUuid1 + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction (enqueueIntegrationEventTx oid sampleIntegrationEnvelope) + now <- getCurrentTime + Right [_] <- Store.runStoreIO storeHandle (claimOutboxBatch PerKeyHeadOfLine 10 now) + Right True <- Store.runStoreIO storeHandle (markOutboxSent oid now) + Right (Just row) <- Store.runStoreIO storeHandle (lookupOutbox oid) + row ^. #status `shouldBe` OutboxSent + row ^. #publishedAt `shouldSatisfy` isJust + row ^. #lastError `shouldBe` Nothing + + it "reclaims a row stranded in publishing by a crashed worker through maintenance" $ \storeHandle -> do + let oid = OutboxId outboxUuid1 + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction (enqueueIntegrationEventTx oid sampleIntegrationEnvelope) + now <- getCurrentTime + let pastNow = addUTCTime (-3600) now + Right [_] <- Store.runStoreIO storeHandle (claimOutboxBatch PerKeyHeadOfLine 10 now) + Right () <- Store.runStoreIO storeHandle (backdateOutboxUpdatedAt oid pastNow) + Right (Just stranded) <- Store.runStoreIO storeHandle (lookupOutbox oid) + stranded ^. #status `shouldBe` OutboxPublishing + publishedRef <- newIORef (0 :: Int) + let publish _ = do + liftIO (modifyIORef' publishedRef (+ 1)) + pure PublishSucceeded + Right noPublish <- Store.runStoreIO storeHandle (publishClaimedOutbox (perRow publish) defaultPublishOptions Nothing) + noPublish ^. #claimed `shouldBe` 0 + Right (Just stillStranded) <- Store.runStoreIO storeHandle (lookupOutbox oid) + stillStranded ^. #status `shouldBe` OutboxPublishing + Right maintenance <- Store.runStoreIO storeHandle (outboxMaintenancePass defaultMaintenanceOptions Nothing) + maintenance ^. #requeued `shouldBe` 1 + maintenance ^. #deadLettered `shouldBe` 0 + Right summary <- Store.runStoreIO storeHandle (publishClaimedOutbox (perRow publish) defaultPublishOptions Nothing) + summary ^. #published `shouldBe` 1 + published <- readIORef publishedRef + published `shouldBe` 1 + Right (Just row) <- Store.runStoreIO storeHandle (lookupOutbox oid) + row ^. #status `shouldBe` OutboxSent + + it "head-of-line traffic unwedges after reclaim" $ \storeHandle -> do + let firstId = OutboxId outboxUuid1 + secondId = OutboxId outboxUuid2 + first = sampleIntegrationEnvelope & #messageId .~ "stuck-first" & #key .~ Just "same-key" + second = sampleIntegrationEnvelope & #messageId .~ "stuck-second" & #key .~ Just "same-key" + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction (enqueueIntegrationEventTx firstId first) + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction (enqueueIntegrationEventTx secondId second) + now <- getCurrentTime + let pastNow = addUTCTime (-3600) now + Right [claimedFirst] <- Store.runStoreIO storeHandle (claimOutboxBatch PerKeyHeadOfLine 1 now) + claimedFirst ^. #outboxId `shouldBe` firstId + Right () <- Store.runStoreIO storeHandle (backdateOutboxUpdatedAt firstId pastNow) + publishedRef <- newIORef [] + let publish row = do + liftIO (modifyIORef' publishedRef (<> [row ^. #outboxId])) + pure PublishSucceeded + Right maintenance <- Store.runStoreIO storeHandle (outboxMaintenancePass defaultMaintenanceOptions Nothing) + maintenance ^. #requeued `shouldBe` 1 + Right firstPass <- Store.runStoreIO storeHandle (publishClaimedOutbox (perRow publish) defaultPublishOptions Nothing) + firstPass ^. #published `shouldBe` 2 + Right secondPass <- Store.runStoreIO storeHandle (publishClaimedOutbox (perRow publish) defaultPublishOptions Nothing) + secondPass ^. #published `shouldBe` 0 + published <- readIORef publishedRef + published `shouldBe` [firstId, secondId] + Right (Just secondRow) <- Store.runStoreIO storeHandle (lookupOutbox secondId) + secondRow ^. #status `shouldBe` OutboxSent + + it "does not reclaim a recently claimed row" $ \storeHandle -> do + let oid = OutboxId outboxUuid1 + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction (enqueueIntegrationEventTx oid sampleIntegrationEnvelope) + now <- getCurrentTime + Right [_] <- Store.runStoreIO storeHandle (claimOutboxBatch PerKeyHeadOfLine 10 now) + publishedRef <- newIORef (0 :: Int) + let publish _ = do + liftIO (modifyIORef' publishedRef (+ 1)) + pure PublishSucceeded + Right summary <- Store.runStoreIO storeHandle (publishClaimedOutbox (perRow publish) defaultPublishOptions Nothing) + summary ^. #claimed `shouldBe` 0 + published <- readIORef publishedRef + published `shouldBe` 0 + Right (Just row) <- Store.runStoreIO storeHandle (lookupOutbox oid) + row ^. #status `shouldBe` OutboxPublishing + + it "a throwing batch publish callback fails every row in that publish call" $ \storeHandle -> do + let throwId = OutboxId outboxUuid1 + okId = OutboxId outboxUuid2 + throwEvent = sampleIntegrationEnvelope & #messageId .~ "throwing-publish" & #key .~ Just "throw-key" + okEvent = sampleIntegrationEnvelope & #messageId .~ "ok-after-throw" & #key .~ Just "ok-key" + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction (enqueueIntegrationEventTx throwId throwEvent) + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction (enqueueIntegrationEventTx okId okEvent) + let publish row + | row ^. #outboxId == throwId = liftIO (throwIO (userError "kafka exploded")) + | otherwise = pure PublishSucceeded + Right summary <- + Store.runStoreIO storeHandle $ + publishClaimedOutbox (perRow publish) (defaultPublishOptions & #backoff .~ ConstantBackoff 0) Nothing + summary ^. #retried `shouldBe` 2 + summary ^. #published `shouldBe` 0 + Right (Just throwRow) <- Store.runStoreIO storeHandle (lookupOutbox throwId) + throwRow ^. #status `shouldBe` OutboxFailed + throwRow ^. #lastError `shouldSatisfy` maybe False (Text.isInfixOf "kafka exploded") + Right (Just okRow) <- Store.runStoreIO storeHandle (lookupOutbox okId) + okRow ^. #status `shouldBe` OutboxFailed + okRow ^. #lastError `shouldSatisfy` maybe False (Text.isInfixOf "kafka exploded") + + it "a row that exhausts attempts while crash-looping is dead-lettered by maintenance" $ \storeHandle -> do + let oid = OutboxId outboxUuid1 + opts = defaultMaintenanceOptions & #maxAttempts .~ 1 + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction (enqueueIntegrationEventTx oid sampleIntegrationEnvelope) + now <- getCurrentTime + let pastNow = addUTCTime (-3600) now + Right [_] <- Store.runStoreIO storeHandle (claimOutboxBatch PerKeyHeadOfLine 10 now) + Right () <- Store.runStoreIO storeHandle (backdateOutboxUpdatedAt oid pastNow) + Right summary <- Store.runStoreIO storeHandle (outboxMaintenancePass opts Nothing) + summary ^. #requeued `shouldBe` 0 + summary ^. #deadLettered `shouldBe` 1 + Right (Just row) <- Store.runStoreIO storeHandle (lookupOutbox oid) + row ^. #status `shouldBe` OutboxDead + + it "markOutboxSent does not resurrect a dead row" $ \storeHandle -> do + let oid = OutboxId outboxUuid1 + opts = defaultPublishOptions & #maxAttempts .~ 1 & #backoff .~ ConstantBackoff 0 + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction (enqueueIntegrationEventTx oid sampleIntegrationEnvelope) + let publish _ = pure (PublishFailed "boom") + Right _ <- Store.runStoreIO storeHandle (publishClaimedOutbox (perRow publish) opts Nothing) + now <- getCurrentTime + Right marked <- Store.runStoreIO storeHandle (markOutboxSent oid now) + marked `shouldBe` False + Right (Just row) <- Store.runStoreIO storeHandle (lookupOutbox oid) + row ^. #status `shouldBe` OutboxDead + + it "publishClaimedOutbox marks success and records failures with last_error" $ \storeHandle -> do + let okId = OutboxId outboxUuid1 + failId = OutboxId outboxUuid2 + okEvent = sampleIntegrationEnvelope + failEvent = + sampleIntegrationEnvelope + & #messageId + .~ "msg-fail-1" + & #key + .~ Just "order-789" + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction (enqueueIntegrationEventTx okId okEvent) + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction (enqueueIntegrationEventTx failId failEvent) + let publish row + | row ^. #outboxId == okId = pure PublishSucceeded + | otherwise = pure (PublishFailed "broker unreachable") + Right summary <- + Store.runStoreIO storeHandle (publishClaimedOutbox (perRow publish) defaultPublishOptions Nothing) + summary ^. #claimed `shouldBe` 2 + summary ^. #published `shouldBe` 1 + summary ^. #retried `shouldBe` 1 + summary ^. #dead `shouldBe` 0 + Right (Just okRow) <- Store.runStoreIO storeHandle (lookupOutbox okId) + okRow ^. #status `shouldBe` OutboxSent + Right (Just failRow) <- Store.runStoreIO storeHandle (lookupOutbox failId) + failRow ^. #status `shouldBe` OutboxFailed + failRow ^. #lastError `shouldBe` Just "broker unreachable" + + it "publishClaimedOutbox hands a same-key run to one batch publish call" $ \storeHandle -> do + let rows = + [ (outboxIdFromOrdinal (fromIntegral i), sampleIntegrationEnvelope & #messageId .~ ("batch-ok-" <> Text.pack (show i)) & #key .~ Just "batch-key") + | i <- [1 .. 10 :: Int] + ] + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + traverse_ (uncurry enqueueIntegrationEventTx) rows + invocationRef <- newIORef (0 :: Int) + let publish claimed = do + liftIO (modifyIORef' invocationRef (+ 1)) + pure [(row ^. #outboxId, PublishSucceeded) | row <- claimed] + Right summary <- Store.runStoreIO storeHandle (publishClaimedOutbox publish defaultPublishOptions Nothing) + summary ^. #claimed `shouldBe` 10 + summary ^. #published `shouldBe` 10 + invocations <- readIORef invocationRef + invocations `shouldBe` 1 + for_ (fmap fst rows) $ \oid -> do + Right (Just row) <- Store.runStoreIO storeHandle (lookupOutbox oid) + row ^. #status `shouldBe` OutboxSent + + it "publishClaimedOutbox skips the same-key suffix after a mid-run failure" $ \storeHandle -> do + let row1Id = outboxIdFromOrdinal 1 + row2Id = outboxIdFromOrdinal 2 + row3Id = outboxIdFromOrdinal 3 + row4Id = outboxIdFromOrdinal 4 + row5Id = outboxIdFromOrdinal 5 + ids = [row1Id, row2Id, row3Id, row4Id, row5Id] + rows = + [ (oid, sampleIntegrationEnvelope & #messageId .~ ("batch-fail-" <> Text.pack (show i)) & #key .~ Just "batch-fail-key") + | (i, oid) <- zip [1 .. 5 :: Int] ids + ] + publish claimed = + pure + [ ( row ^. #outboxId, + if row ^. #outboxId == row3Id + then PublishFailed "pivot failed" + else PublishSucceeded + ) + | row <- claimed + ] + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + traverse_ (uncurry enqueueIntegrationEventTx) rows + Right summary <- + Store.runStoreIO storeHandle $ + publishClaimedOutbox publish (defaultPublishOptions & #backoff .~ ConstantBackoff 0) Nothing + summary ^. #published `shouldBe` 2 + summary ^. #retried `shouldBe` 3 + Right (Just row1) <- Store.runStoreIO storeHandle (lookupOutbox row1Id) + Right (Just row2) <- Store.runStoreIO storeHandle (lookupOutbox row2Id) + Right (Just row3) <- Store.runStoreIO storeHandle (lookupOutbox row3Id) + Right (Just row4) <- Store.runStoreIO storeHandle (lookupOutbox row4Id) + Right (Just row5) <- Store.runStoreIO storeHandle (lookupOutbox row5Id) + row1 ^. #status `shouldBe` OutboxSent + row2 ^. #status `shouldBe` OutboxSent + row3 ^. #status `shouldBe` OutboxFailed + row3 ^. #attemptCount `shouldBe` 1 + row3 ^. #lastError `shouldBe` Just "pivot failed" + row4 ^. #status `shouldBe` OutboxFailed + row4 ^. #attemptCount `shouldBe` 0 + row4 ^. #lastError `shouldBe` Just "skipped: earlier record for the same key failed" + row5 ^. #status `shouldBe` OutboxFailed + row5 ^. #attemptCount `shouldBe` 0 + + it "PerSourceStream keeps one source's failure from skipping another source's rows" $ \storeHandle -> do + let rowA1 = outboxIdFromOrdinal 1 + rowB1 = outboxIdFromOrdinal 2 + rowA2 = outboxIdFromOrdinal 3 + rowB2 = outboxIdFromOrdinal 4 + mkRow oid src msgId = + (oid, sampleIntegrationEnvelope & #messageId .~ msgId & #source .~ src & #key .~ Nothing) + rows = + [ mkRow rowA1 "per-source-a" "ps-a1", + mkRow rowB1 "per-source-b" "ps-b1", + mkRow rowA2 "per-source-a" "ps-a2", + mkRow rowB2 "per-source-b" "ps-b2" + ] + publish claimed = + pure + [ ( row ^. #outboxId, + if row ^. #outboxId == rowA2 + then PublishFailed "source-a pivot failed" + else PublishSucceeded + ) + | row <- claimed + ] + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + traverse_ (uncurry enqueueIntegrationEventTx) rows + Right summary <- + Store.runStoreIO storeHandle $ + publishClaimedOutbox publish (defaultPublishOptions & #orderingPolicy .~ PerSourceStream & #backoff .~ ConstantBackoff 0) Nothing + summary ^. #claimed `shouldBe` 4 + summary ^. #published `shouldBe` 3 + summary ^. #retried `shouldBe` 1 + Right (Just a1) <- Store.runStoreIO storeHandle (lookupOutbox rowA1) + Right (Just a2) <- Store.runStoreIO storeHandle (lookupOutbox rowA2) + Right (Just b1) <- Store.runStoreIO storeHandle (lookupOutbox rowB1) + Right (Just b2) <- Store.runStoreIO storeHandle (lookupOutbox rowB2) + a1 ^. #status `shouldBe` OutboxSent + a2 ^. #status `shouldBe` OutboxFailed + a2 ^. #attemptCount `shouldBe` 1 + a2 ^. #lastError `shouldBe` Just "source-a pivot failed" + b1 ^. #status `shouldBe` OutboxSent + b2 ^. #status `shouldBe` OutboxSent + + it "a late failure mark does not clobber a row that already reached a terminal state" $ \storeHandle -> do + let oid = OutboxId outboxUuid1 + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction (enqueueIntegrationEventTx oid sampleIntegrationEnvelope) + now <- getCurrentTime + Right [_] <- Store.runStoreIO storeHandle (claimOutboxBatch PerKeyHeadOfLine 10 now) + Right True <- Store.runStoreIO storeHandle (markOutboxSent oid now) + Right _ <- + Store.runStoreIO storeHandle $ + Store.runTransaction (markOutboxFailedTx oid "late failure from a timed-out worker" 5 60 now) + Right (Just row) <- Store.runStoreIO storeHandle (lookupOutbox oid) + row ^. #status `shouldBe` OutboxSent + row ^. #lastError `shouldBe` Nothing + + it "claims nothing while another transaction holds an uncommitted claim on a key's head" $ \storeHandle -> do + let headId = outboxIdFromOrdinal 1 + tailId = outboxIdFromOrdinal 2 + rows = + [ (headId, sampleIntegrationEnvelope & #messageId .~ "claim-race-1" & #key .~ Just "claim-race-key"), + (tailId, sampleIntegrationEnvelope & #messageId .~ "claim-race-2" & #key .~ Just "claim-race-key") + ] + OutboxId headUuid = headId + holdClaimSql = + TE.encodeUtf8 $ + "UPDATE keiro.keiro_outbox SET status = 'publishing', attempt_count = attempt_count + 1, updated_at = now() WHERE outbox_id = '" + <> UUID.toText headUuid + <> "'" + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + traverse_ (uncurry enqueueIntegrationEventTx) rows + holderDone <- newEmptyMVar + _ <- forkIO $ do + holder <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ do + Tx.sql holdClaimSql + Tx.sql "SELECT pg_sleep(2)" + putMVar holderDone holder + -- Let the holder acquire its uncommitted row lock, then race a claim. + threadDelay 500000 + now <- getCurrentTime + Right claimed <- Store.runStoreIO storeHandle (claimOutboxBatch PerKeyHeadOfLine 10 now) + fmap (^. #outboxId) claimed `shouldBe` [] + Right () <- takeMVar holderDone + pure () + + it "StopTheLine publishes singleton batches and skips the unattempted suffix" $ \storeHandle -> do + let row1Id = outboxIdFromOrdinal 1 + row2Id = outboxIdFromOrdinal 2 + row3Id = outboxIdFromOrdinal 3 + row4Id = outboxIdFromOrdinal 4 + ids = [row1Id, row2Id, row3Id, row4Id] + rows = + [ (oid, sampleIntegrationEnvelope & #messageId .~ ("stop-line-" <> Text.pack (show i)) & #key .~ Just "stop-key") + | (i, oid) <- zip [1 .. 4 :: Int] ids + ] + publishRef = fmap (^. #outboxId) + publish claimed = + pure + [ ( row ^. #outboxId, + if row ^. #outboxId == row2Id + then PublishFailed "stop here" + else PublishSucceeded + ) + | row <- claimed + ] + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + traverse_ (uncurry enqueueIntegrationEventTx) rows + seenRef <- newIORef [] + let trackedPublish claimed = do + liftIO (modifyIORef' seenRef (<> publishRef claimed)) + publish claimed + opts = defaultPublishOptions & #orderingPolicy .~ StopTheLine & #backoff .~ ConstantBackoff 0 + Right summary <- Store.runStoreIO storeHandle (publishClaimedOutbox trackedPublish opts Nothing) + summary ^. #published `shouldBe` 1 + summary ^. #retried `shouldBe` 3 + summary ^. #haltedOn `shouldBe` Just row2Id + seen <- readIORef seenRef + seen `shouldBe` take 2 ids + Right (Just row3) <- Store.runStoreIO storeHandle (lookupOutbox row3Id) + Right (Just row4) <- Store.runStoreIO storeHandle (lookupOutbox row4Id) + row3 ^. #status `shouldBe` OutboxFailed + row3 ^. #attemptCount `shouldBe` 0 + row4 ^. #status `shouldBe` OutboxFailed + row4 ^. #attemptCount `shouldBe` 0 + + it "publishClaimedOutbox treats a missing batch outcome as a failed row" $ \storeHandle -> do + let okId = outboxIdFromOrdinal 1 + missingId = outboxIdFromOrdinal 2 + okEvent = sampleIntegrationEnvelope & #messageId .~ "missing-outcome-ok" & #key .~ Just "ok-key" + missingEvent = sampleIntegrationEnvelope & #messageId .~ "missing-outcome-fail" & #key .~ Just "missing-key" + publish claimed = + pure + [ (row ^. #outboxId, PublishSucceeded) + | row <- claimed, + row ^. #outboxId == okId + ] + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ do + enqueueIntegrationEventTx okId okEvent + enqueueIntegrationEventTx missingId missingEvent + Right summary <- Store.runStoreIO storeHandle (publishClaimedOutbox publish defaultPublishOptions Nothing) + summary ^. #published `shouldBe` 1 + summary ^. #retried `shouldBe` 1 + Right (Just missingRow) <- Store.runStoreIO storeHandle (lookupOutbox missingId) + missingRow ^. #status `shouldBe` OutboxFailed + missingRow ^. #lastError `shouldBe` Just "publisher returned no outcome" + + it "auto-dead-letters a row after maxAttempts consecutive failures" $ \storeHandle -> do + let oid = OutboxId outboxUuid1 + event = sampleIntegrationEnvelope & #key .~ Nothing + opts = + defaultPublishOptions + & #batchSize + .~ 10 + & #maxAttempts + .~ 3 + & #backoff + .~ ConstantBackoff 0 + & #orderingPolicy + .~ BestEffort + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction (enqueueIntegrationEventTx oid event) + let publish _ = pure (PublishFailed "broker exploded") + -- First two failures retain Failed status. + Right s1 <- Store.runStoreIO storeHandle (publishClaimedOutbox (perRow publish) opts Nothing) + s1 ^. #retried `shouldBe` 1 + s1 ^. #dead `shouldBe` 0 + Right s2 <- Store.runStoreIO storeHandle (publishClaimedOutbox (perRow publish) opts Nothing) + s2 ^. #retried `shouldBe` 1 + s2 ^. #dead `shouldBe` 0 + -- Third failure crosses the threshold. + Right s3 <- Store.runStoreIO storeHandle (publishClaimedOutbox (perRow publish) opts Nothing) + s3 ^. #dead `shouldBe` 1 + Right (Just row) <- Store.runStoreIO storeHandle (lookupOutbox oid) + row ^. #status `shouldBe` OutboxDead + -- A dead row is not claimable. + now <- getCurrentTime + Right reclaimed <- Store.runStoreIO storeHandle (claimOutboxBatch BestEffort 10 now) + reclaimed `shouldBe` [] + + it "garbageCollectSent deletes only old sent rows" $ \storeHandle -> do + let oldSentId = OutboxId outboxUuid1 + recentSentId = OutboxId outboxUuid2 + failedId = OutboxId outboxUuid3 + deadId = OutboxId outboxUuid4 + base = sampleIntegrationEnvelope & #key .~ Nothing + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction (enqueueIntegrationEventTx oldSentId (base & #messageId .~ "gc-old-sent")) + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction (enqueueIntegrationEventTx recentSentId (base & #messageId .~ "gc-recent-sent")) + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction (enqueueIntegrationEventTx failedId (base & #messageId .~ "gc-failed")) + let firstPass row + | row ^. #outboxId == failedId = pure (PublishFailed "keep failed") + | otherwise = pure PublishSucceeded + firstPassOpts = + defaultPublishOptions + & #batchSize + .~ 10 + & #orderingPolicy + .~ BestEffort + & #backoff + .~ ConstantBackoff 3600 + Right _ <- Store.runStoreIO storeHandle (publishClaimedOutbox (perRow firstPass) firstPassOpts Nothing) + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction (enqueueIntegrationEventTx deadId (base & #messageId .~ "gc-dead")) + let deadPass row + | row ^. #outboxId == deadId = pure (PublishFailed "keep dead") + | otherwise = pure PublishSucceeded + deadPassOpts = + defaultPublishOptions + & #batchSize + .~ 10 + & #maxAttempts + .~ 1 + & #orderingPolicy + .~ BestEffort + Right _ <- Store.runStoreIO storeHandle (publishClaimedOutbox (perRow deadPass) deadPassOpts Nothing) + now <- getCurrentTime + Right () <- Store.runStoreIO storeHandle (backdateOutboxPublishedAt oldSentId (addUTCTime (-3600) now)) + Right deleted <- Store.runStoreIO storeHandle (garbageCollectSent 300 now) + deleted `shouldBe` 1 + Right oldRow <- Store.runStoreIO storeHandle (lookupOutbox oldSentId) + oldRow `shouldBe` Nothing + Right (Just recentRow) <- Store.runStoreIO storeHandle (lookupOutbox recentSentId) + recentRow ^. #status `shouldBe` OutboxSent + Right (Just failedRow) <- Store.runStoreIO storeHandle (lookupOutbox failedId) + failedRow ^. #status `shouldBe` OutboxFailed + Right (Just deadRow) <- Store.runStoreIO storeHandle (lookupOutbox deadId) + deadRow ^. #status `shouldBe` OutboxDead + + it "enforces per-key head-of-line blocking and unblocks once the predecessor reaches a terminal state" $ \storeHandle -> do + let a1Id = OutboxId outboxUuid1 + a2Id = OutboxId outboxUuid2 + b1Id = OutboxId outboxUuid3 + a1 = sampleIntegrationEnvelope & #messageId .~ "a1" & #key .~ Just "k1" + a2 = sampleIntegrationEnvelope & #messageId .~ "a2" & #key .~ Just "k1" + b1 = sampleIntegrationEnvelope & #messageId .~ "b1" & #key .~ Just "k2" + -- Insert in created_at order (a1 first, then a2, then b1). + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction (enqueueIntegrationEventTx a1Id a1) + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction (enqueueIntegrationEventTx a2Id a2) + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction (enqueueIntegrationEventTx b1Id b1) + claimed <- newIORef [] + let publish row = do + liftIO (atomicModifyIORef' claimed (\xs -> ((row ^. #outboxId) : xs, ()))) + if row ^. #outboxId == a1Id + then pure (PublishFailed "broker hiccup") + else pure PublishSucceeded + -- First pass: with a one-row batch, a1 fails and both later rows remain pending. + let firstPassOpts = + defaultPublishOptions + & #batchSize + .~ 1 + & #backoff + .~ ConstantBackoff 0 + Right summary1 <- + Store.runStoreIO storeHandle (publishClaimedOutbox (perRow publish) firstPassOpts Nothing) + summary1 ^. #claimed `shouldBe` 1 + claimedIds <- readIORef claimed + claimedIds `shouldSatisfy` (a2Id `notElem`) + claimedIds `shouldSatisfy` (a1Id `elem`) + claimedIds `shouldSatisfy` (b1Id `notElem`) + Right (Just a1Row) <- Store.runStoreIO storeHandle (lookupOutbox a1Id) + a1Row ^. #status `shouldBe` OutboxFailed + Right (Just b1Row) <- Store.runStoreIO storeHandle (lookupOutbox b1Id) + b1Row ^. #status `shouldBe` OutboxPending + Right (Just a2Row) <- Store.runStoreIO storeHandle (lookupOutbox a2Id) + a2Row ^. #status `shouldBe` OutboxPending + -- Drive a1 to terminal sent state so a2 can move. One pass claims a1 + -- (now that next_attempt_at has passed). A second pass claims a2, + -- which becomes head-of-line once a1 reaches `sent`. + writeIORef claimed [] + let publishOk row = do + liftIO (atomicModifyIORef' claimed (\xs -> ((row ^. #outboxId) : xs, ()))) + pure PublishSucceeded + retryOpts = + defaultPublishOptions + & #batchSize + .~ 1 + & #backoff + .~ ConstantBackoff 0 + Right _ <- Store.runStoreIO storeHandle (publishClaimedOutbox (perRow publishOk) retryOpts Nothing) + Right _ <- Store.runStoreIO storeHandle (publishClaimedOutbox (perRow publishOk) retryOpts Nothing) + Right _ <- Store.runStoreIO storeHandle (publishClaimedOutbox (perRow publishOk) retryOpts Nothing) + claimedIds2 <- readIORef claimed + claimedIds2 `shouldSatisfy` (a1Id `elem`) + claimedIds2 `shouldSatisfy` (a2Id `elem`) + claimedIds2 `shouldSatisfy` (b1Id `elem`) + Right (Just a2Row') <- Store.runStoreIO storeHandle (lookupOutbox a2Id) + a2Row' ^. #status `shouldBe` OutboxSent + + it "allows null-keyed rows to publish independently" $ \storeHandle -> do + let n1 = OutboxId outboxUuid1 + n2 = OutboxId outboxUuid2 + e = sampleIntegrationEnvelope & #key .~ Nothing + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction (enqueueIntegrationEventTx n1 (e & #messageId .~ "n1")) + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction (enqueueIntegrationEventTx n2 (e & #messageId .~ "n2")) + let publish row + | row ^. #outboxId == n1 = pure (PublishFailed "transient") + | otherwise = pure PublishSucceeded + Right summary <- + Store.runStoreIO storeHandle $ + publishClaimedOutbox (perRow publish) (defaultPublishOptions & #backoff .~ ConstantBackoff 0) Nothing + summary ^. #claimed `shouldBe` 2 + summary ^. #published `shouldBe` 1 + summary ^. #retried `shouldBe` 1 + + it "mints message ids with the configured TypeID prefix" $ \storeHandle -> do + Right minted <- + Store.runStoreIO storeHandle (mintIntegrationEvent sampleProducer sampleDraft) + minted ^. #source `shouldBe` "ordering" + minted ^. #destination `shouldBe` "billing.orders.v1" + Text.isPrefixOf "msg_" (minted ^. #messageId) `shouldBe` True + + it "validates integration producer message id prefixes before startup" $ \_storeHandle -> do + shouldBeRight_ (mkIntegrationProducer sampleProducer) + case mkIntegrationProducer (sampleProducer & #messageIdPrefix .~ "Bad-Prefix") of + Left (InvalidMessageIdPrefix prefix reason) -> do + prefix `shouldBe` "Bad-Prefix" + reason `shouldSatisfy` (not . Text.null) + other -> expectationFailure ("expected invalid prefix, got " <> show (void other)) + + it "draftToEvent stamps source and messageId without minting" $ \_storeHandle -> do + let event = draftToEvent "ordering" "msg-fixed-1" sampleDraft + event ^. #messageId `shouldBe` "msg-fixed-1" + event ^. #source `shouldBe` "ordering" + event ^. #destination `shouldBe` "billing.orders.v1" + + it "freshOutboxId returns distinct UUIDv7 ids" $ \storeHandle -> do + Right ids <- + Store.runStoreIO storeHandle (traverse (\_ -> freshOutboxId) [1 .. 4 :: Int]) + length ids `shouldBe` 4 + length (uniqueIds ids) `shouldBe` 4 + + it "publishClaimedOutbox emits a Producer span with messaging semconv attributes" $ \storeHandle -> do + (processor, spansRef) <- inMemoryListExporter + provider <- createTracerProvider [processor] emptyTracerProviderOptions + let tracer = makeTracer provider "keiro-test" tracerOptions + okId = OutboxId outboxUuid1 + failId = OutboxId outboxUuid2 + okEvent = sampleIntegrationEnvelope + failEvent = + sampleIntegrationEnvelope + & #messageId + .~ "msg-fail-otel-1" + & #key + .~ Just "order-otel-fail" + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction (enqueueIntegrationEventTx okId okEvent) + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction (enqueueIntegrationEventTx failId failEvent) + let publish row + | row ^. #outboxId == okId = pure PublishSucceeded + | otherwise = pure (PublishFailed "broker unreachable") + opts = defaultPublishOptions & #tracer ?~ tracer + Right _ <- Store.runStoreIO storeHandle (publishClaimedOutbox (perRow publish) opts Nothing) + _ <- shutdownTracerProvider provider Nothing + spans <- traverse captureSpan =<< readIORef spansRef + length spans `shouldBe` 1 + case spans of + [batchSpan] -> do + csName batchSpan `shouldBe` ("send " <> (okEvent ^. #destination)) + show (csKind batchSpan) `shouldBe` "Producer" + textAttr (csAttributes batchSpan) "messaging.system" `shouldBe` Just "kafka" + textAttr (csAttributes batchSpan) "messaging.operation.type" `shouldBe` Just "publish" + textAttr (csAttributes batchSpan) "messaging.operation.name" `shouldBe` Just "send" + textAttr (csAttributes batchSpan) "messaging.destination.name" + `shouldBe` Just (okEvent ^. #destination) + textAttr (csAttributes batchSpan) "messaging.kafka.message.key" + `shouldBe` (okEvent ^. #key) + intAttr (csAttributes batchSpan) "keiro.outbox.batch.size" `shouldBe` Just 2 + textAttr (csAttributes batchSpan) "error.type" `shouldBe` Just "publish_failed" + case csStatus batchSpan of + Error msg -> msg `shouldBe` "broker unreachable" + other -> expectationFailure ("expected Error \"broker unreachable\", got " <> show other) + other -> expectationFailure ("expected one batch span, got " <> show (length other)) + + it "publishClaimedOutbox records counters and sampleOutboxBacklog records the gauge" $ \storeHandle -> do + (exporter, metricsRef) <- inMemoryMetricExporter + (provider, _env) <- + createMeterProvider + emptyMaterializedResources + defaultSdkMeterProviderOptions {metricExporter = Just exporter} + meter <- getMeter provider Telemetry.keiroInstrumentationLibrary + keiroMetrics <- Telemetry.newKeiroMetrics meter + let okId = OutboxId outboxUuid1 + failId = OutboxId outboxUuid2 + okEvent = sampleIntegrationEnvelope & #messageId .~ "metrics-ok" & #key .~ Nothing + failEvent = sampleIntegrationEnvelope & #messageId .~ "metrics-fail" & #key .~ Nothing + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction (enqueueIntegrationEventTx okId okEvent) + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction (enqueueIntegrationEventTx failId failEvent) + let publish row + | row ^. #outboxId == okId = pure PublishSucceeded + | otherwise = pure (PublishFailed "broker down") + retryPassOpts = + defaultPublishOptions + & #batchSize + .~ 10 + & #maxAttempts + .~ 5 + & #backoff + .~ ConstantBackoff 0 + & #orderingPolicy + .~ BestEffort + deadPassOpts = retryPassOpts & #maxAttempts .~ 1 + -- Pass 1 (maxAttempts = 5): ok publishes, the fail row retries. + Right summary1 <- + Store.runStoreIO storeHandle (publishClaimedOutbox (perRow publish) retryPassOpts (Just keiroMetrics)) + summary1 ^. #published `shouldBe` 1 + summary1 ^. #retried `shouldBe` 1 + -- Pass 2 (maxAttempts = 1): the failed row crosses the ceiling and dies. + Right summary2 <- + Store.runStoreIO storeHandle (publishClaimedOutbox (perRow publish) deadPassOpts (Just keiroMetrics)) + summary2 ^. #dead `shouldBe` 1 + -- Flush so the in-memory exporter receives the aggregates. + _ <- forceFlushMeterProvider provider Nothing + exported <- readIORef metricsRef + let scalars = flattenScalarPoints exported + -- Counters are cumulative across both passes. + lookup "keiro.outbox.published" scalars `shouldBe` Just (IntNumber 1) + lookup "keiro.outbox.retried" scalars `shouldBe` Just (IntNumber 1) + lookup "keiro.outbox.deadlettered" scalars `shouldBe` Just (IntNumber 1) + -- Publish passes no longer run the backlog COUNT(*) on the hot path. + lookup "keiro.outbox.backlog" scalars `shouldBe` Nothing + + Store.runStoreIO storeHandle (sampleOutboxBacklog (Just keiroMetrics)) `shouldReturn` Right () + _ <- forceFlushMeterProvider provider Nothing + sampled <- readIORef metricsRef + let sampledScalars = flattenScalarPoints sampled + lookup "keiro.outbox.backlog" sampledScalars `shouldBe` Just (IntNumber 0) + + describe "Keiro.Inbox" $ around (withFreshStore fixture) $ do + it "runs the handler once and records the row as completed" $ \storeHandle -> do + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction (Tx.sql "CREATE TABLE IF NOT EXISTS inbox_test_counter (message_id TEXT PRIMARY KEY)") + let event = + sampleIntegrationEnvelope + & #messageId + .~ "inbox-msg-1" + & #source + .~ "ordering" + handler ev = + Tx.statement (ev ^. #messageId) inboxTestCounterInsertStmt + Right result1 <- + Store.runStoreIO storeHandle $ + runInboxTransaction Nothing PreferIntegrationMessageId event Nothing handler + case result1 of + Right (InboxProcessed ()) -> pure () + other -> expectationFailure ("expected InboxProcessed, got " <> show other) + Right rowCount1 <- + Store.runStoreIO storeHandle $ + Store.runTransaction (Tx.statement () inboxTestCounterCountStmt) + rowCount1 `shouldBe` 1 + Right (Just inboxRow) <- Store.runStoreIO storeHandle (lookupInbox "ordering" "inbox-msg-1") + inboxRow ^. #status `shouldBe` InboxCompleted + inboxRow ^. #completedAt `shouldSatisfy` isJust + + it "treats a redelivery with the same messageId as a duplicate" $ \storeHandle -> do + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction (Tx.sql "CREATE TABLE IF NOT EXISTS inbox_test_counter (message_id TEXT PRIMARY KEY)") + let event = + sampleIntegrationEnvelope + & #messageId + .~ "inbox-msg-dup" + & #source + .~ "ordering" + handler ev = Tx.statement (ev ^. #messageId) inboxTestCounterInsertStmt + Right (Right (InboxProcessed ())) <- + Store.runStoreIO storeHandle $ + runInboxTransaction Nothing PreferIntegrationMessageId event Nothing handler + Right result2 <- + Store.runStoreIO storeHandle $ + runInboxTransaction Nothing PreferIntegrationMessageId event Nothing handler + result2 `shouldBe` Right InboxDuplicate + Right rowCount <- + Store.runStoreIO storeHandle $ + Store.runTransaction (Tx.statement () inboxTestCounterCountStmt) + rowCount `shouldBe` 1 + + it "records inbox counters and samples backlog separately under the in-memory exporter" $ \storeHandle -> do + (exporter, metricsRef) <- inMemoryMetricExporter + (provider, _env) <- + createMeterProvider + emptyMaterializedResources + defaultSdkMeterProviderOptions {metricExporter = Just exporter} + meter <- getMeter provider Telemetry.keiroInstrumentationLibrary + keiroMetrics <- Telemetry.newKeiroMetrics meter + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction (Tx.sql "CREATE TABLE IF NOT EXISTS inbox_test_counter (message_id TEXT PRIMARY KEY)") + let event = sampleIntegrationEnvelope & #messageId .~ "inbox-metrics-dup" & #source .~ "ordering" + handler ev = Tx.statement (ev ^. #messageId) inboxTestCounterInsertStmt + -- First delivery runs the handler: processed. + Right (Right (InboxProcessed ())) <- + Store.runStoreIO storeHandle $ + runInboxTransaction (Just keiroMetrics) PreferIntegrationMessageId event Nothing handler + -- Second delivery of the same (source, message_id): duplicate. + Right result2 <- + Store.runStoreIO storeHandle $ + runInboxTransaction (Just keiroMetrics) PreferIntegrationMessageId event Nothing handler + result2 `shouldBe` Right InboxDuplicate + _ <- forceFlushMeterProvider provider Nothing + exported <- readIORef metricsRef + let scalars = flattenScalarPoints exported + lookup "keiro.inbox.processed" scalars `shouldBe` Just (IntNumber 1) + lookup "keiro.inbox.duplicates" scalars `shouldBe` Just (IntNumber 1) + lookup "keiro.inbox.backlog" scalars `shouldBe` Nothing + Store.runStoreIO storeHandle (sampleInboxBacklog (Just keiroMetrics)) `shouldReturn` Right () + _ <- forceFlushMeterProvider provider Nothing + sampled <- readIORef metricsRef + let sampledScalars = flattenScalarPoints sampled + lookup "keiro.inbox.backlog" sampledScalars `shouldBe` Just (IntNumber 0) + -- The handler ran exactly once (the duplicate path does not re-run it). + Right rowCount <- + Store.runStoreIO storeHandle $ + Store.runTransaction (Tx.statement () inboxTestCounterCountStmt) + rowCount `shouldBe` 1 + + it "deduplicates via PreferSourceEventIdentity even when messageId differs" $ \storeHandle -> do + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction (Tx.sql "CREATE TABLE IF NOT EXISTS inbox_test_counter (message_id TEXT PRIMARY KEY)") + let shared = sampleIntegrationEnvelope & #source .~ "ordering" + first = shared & #messageId .~ "republish-1" + second = shared & #messageId .~ "republish-2" + handler ev = Tx.statement (ev ^. #messageId) inboxTestCounterInsertStmt + Right (Right (InboxProcessed ())) <- + Store.runStoreIO storeHandle $ + runInboxTransaction Nothing PreferSourceEventIdentity first Nothing handler + Right result2 <- + Store.runStoreIO storeHandle $ + runInboxTransaction Nothing PreferSourceEventIdentity second Nothing handler + result2 `shouldBe` Right InboxDuplicate + + it "uses KafkaDeliveryIdentity when supplied" $ \storeHandle -> do + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction (Tx.sql "CREATE TABLE IF NOT EXISTS inbox_test_counter (message_id TEXT PRIMARY KEY)") + let event = sampleIntegrationEnvelope & #source .~ "ordering" + kafka = KafkaDeliveryRef "billing.orders.v1" 0 17 + handler ev = Tx.statement (ev ^. #messageId) inboxTestCounterInsertStmt + Right (Right (InboxProcessed ())) <- + Store.runStoreIO storeHandle $ + runInboxTransaction Nothing KafkaDeliveryIdentity event (Just kafka) handler + Right (Right InboxDuplicate) <- + Store.runStoreIO storeHandle $ + runInboxTransaction Nothing KafkaDeliveryIdentity event (Just kafka) handler + Right (Just row) <- + Store.runStoreIO storeHandle $ + lookupInbox "ordering" "billing.orders.v1:0:17" + row ^. #status `shouldBe` InboxCompleted + + it "reports DedupePolicyUnsatisfied when the envelope lacks the required field" $ \storeHandle -> do + let event = + sampleIntegrationEnvelope + & #source + .~ "ordering" + & #sourceEventId + .~ Nothing + & #sourceGlobalPosition + .~ Nothing + Right result <- + Store.runStoreIO storeHandle $ + runInboxTransaction Nothing PreferSourceEventIdentity event Nothing (\_ -> pure ()) + result `shouldBe` Left (DedupePolicyUnsatisfied PreferSourceEventIdentity) + + it "leaves no inbox row when the handler condemns the transaction" $ \storeHandle -> do + let event = + sampleIntegrationEnvelope + & #messageId + .~ "inbox-msg-rollback" + & #source + .~ "ordering" + handler _ = do + Tx.condemn + pure () + _ <- + Store.runStoreIO storeHandle $ + runInboxTransaction Nothing PreferIntegrationMessageId event Nothing handler + Right row <- Store.runStoreIO storeHandle (lookupInbox "ordering" "inbox-msg-rollback") + row `shouldBe` Nothing + + it "leaves no inbox row when the plain handler throws" $ \storeHandle -> do + let event = + sampleIntegrationEnvelope + & #messageId + .~ "inbox-msg-throw-plain" + & #source + .~ "ordering" + handler _ = (pure $! error "plain inbox handler failed") :: Tx.Transaction () + thrown <- + try $ + Store.runStoreIO storeHandle $ + runInboxTransaction Nothing PreferIntegrationMessageId event Nothing handler + case thrown of + Left (_ :: SomeException) -> pure () + Right other -> expectationFailure ("expected handler exception, got " <> show (void other)) + Right row <- Store.runStoreIO storeHandle (lookupInbox "ordering" "inbox-msg-throw-plain") + row `shouldBe` Nothing + + it "exports markFailedTx from the public inbox module and preserves explicit failure marks" $ \storeHandle -> do + let event = + sampleIntegrationEnvelope + & #messageId + .~ "inbox-msg-public-failed" + & #source + .~ "ordering" + handler _ = do + markFailedTx "ordering" "inbox-msg-public-failed" "operator failed" (event ^. #occurredAt) + pure () + Right (Right (InboxProcessed ())) <- + Store.runStoreIO storeHandle $ + runInboxTransaction Nothing PreferIntegrationMessageId event Nothing handler + Right (Just row) <- Store.runStoreIO storeHandle (lookupInbox "ordering" "inbox-msg-public-failed") + row ^. #status `shouldBe` InboxFailed + row ^. #lastError `shouldBe` Just "operator failed" + + it "a throwing handler records a failed attempt instead of looping" $ \storeHandle -> do + let event = + sampleIntegrationEnvelope + & #messageId + .~ "inbox-msg-poison-1" + & #source + .~ "ordering" + handler _ = (pure $! error "inbox exploded") :: Tx.Transaction () + Right result <- + Store.runStoreIO storeHandle $ + runInboxTransactionWithRetries Nothing 3 PreferIntegrationMessageId event Nothing handler + case result of + Right (InboxHandlerFailed err attempts) -> do + Text.isInfixOf "inbox exploded" err `shouldBe` True + attempts `shouldBe` 1 + other -> expectationFailure ("expected InboxHandlerFailed, got " <> show other) + Right (Just row) <- Store.runStoreIO storeHandle (lookupInbox "ordering" "inbox-msg-poison-1") + row ^. #status `shouldBe` InboxFailed + row ^. #attemptCount `shouldBe` 1 + row ^. #lastError `shouldSatisfy` maybe False (Text.isInfixOf "inbox exploded") + + it "a transient poison message succeeds on retry" $ \storeHandle -> do + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction (Tx.sql "CREATE TABLE IF NOT EXISTS inbox_test_counter (message_id TEXT PRIMARY KEY)") + let event = + sampleIntegrationEnvelope + & #messageId + .~ "inbox-msg-poison-transient" + & #source + .~ "ordering" + failOnce _ = (pure $! error "temporary inbox failure") :: Tx.Transaction () + succeeding ev = Tx.statement (ev ^. #messageId) inboxTestCounterInsertStmt + Right result1 <- + Store.runStoreIO storeHandle $ + runInboxTransactionWithRetries Nothing 3 PreferIntegrationMessageId event Nothing failOnce + case result1 of + Right (InboxHandlerFailed _ 1) -> pure () + other -> expectationFailure ("expected first failed attempt, got " <> show other) + Right result2 <- + Store.runStoreIO storeHandle $ + runInboxTransactionWithRetries Nothing 3 PreferIntegrationMessageId event Nothing succeeding + result2 `shouldBe` Right (InboxProcessed ()) + Right (Just row) <- Store.runStoreIO storeHandle (lookupInbox "ordering" "inbox-msg-poison-transient") + row ^. #status `shouldBe` InboxCompleted + row ^. #attemptCount `shouldBe` 1 + Right rowCount <- + Store.runStoreIO storeHandle $ + Store.runTransaction (Tx.statement () inboxTestCounterCountStmt) + rowCount `shouldBe` 1 + + it "an unrecoverable message dead-letters at the ceiling" $ \storeHandle -> do + let event = + sampleIntegrationEnvelope + & #messageId + .~ "inbox-msg-poison-dead" + & #source + .~ "ordering" + handler _ = (pure $! error "always broken") :: Tx.Transaction () + Right result1 <- + Store.runStoreIO storeHandle $ + runInboxTransactionWithRetries Nothing 2 PreferIntegrationMessageId event Nothing handler + Right result2 <- + Store.runStoreIO storeHandle $ + runInboxTransactionWithRetries Nothing 2 PreferIntegrationMessageId event Nothing handler + Right result3 <- + Store.runStoreIO storeHandle $ + runInboxTransactionWithRetries Nothing 2 PreferIntegrationMessageId event Nothing handler + case (result1, result2, result3) of + ( Right (InboxHandlerFailed _ 1), + Right (InboxHandlerFailed _ 2), + Right (InboxPreviouslyFailed _) + ) -> pure () + other -> expectationFailure ("unexpected poison lifecycle: " <> show other) + Right (Just row) <- Store.runStoreIO storeHandle (lookupInbox "ordering" "inbox-msg-poison-dead") + row ^. #status `shouldBe` InboxFailed + row ^. #attemptCount `shouldBe` 2 + + it "processes a batch of distinct messages in one transaction" $ \storeHandle -> do + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction (Tx.sql "CREATE TABLE IF NOT EXISTS inbox_test_counter (message_id TEXT PRIMARY KEY)") + let events = + [ sampleIntegrationEnvelope + & #messageId + .~ ("inbox-batch-msg-" <> Text.pack (show n)) + & #source + .~ "batch-ordering" + | n <- [1 .. 50 :: Int] + ] + handler ev = Tx.statement (ev ^. #messageId) inboxTestCounterInsertStmt + Right results <- + Store.runStoreIO storeHandle $ + runInboxTransactionBatch Nothing 3 PreferIntegrationMessageId PersistFullEnvelope ((,Nothing) <$> events) handler + results `shouldBe` replicate 50 (Right (InboxProcessed ())) + Right rowCount <- + Store.runStoreIO storeHandle $ + Store.runTransaction (Tx.statement () inboxTestCounterCountStmt) + rowCount `shouldBe` 50 + Right inboxRows <- Store.runStoreIO storeHandle (listInbox "batch-ordering") + length inboxRows `shouldBe` 50 + all ((== InboxCompleted) . (^. #status)) inboxRows `shouldBe` True + + it "deduplicates repeated messages within one batch" $ \storeHandle -> do + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction (Tx.sql "CREATE TABLE IF NOT EXISTS inbox_test_counter (message_id TEXT PRIMARY KEY)") + let event = + sampleIntegrationEnvelope + & #messageId + .~ "inbox-batch-dup" + & #source + .~ "batch-ordering" + handler ev = Tx.statement (ev ^. #messageId) inboxTestCounterInsertStmt + Right results <- + Store.runStoreIO storeHandle $ + runInboxTransactionBatch Nothing 3 PreferIntegrationMessageId PersistFullEnvelope [(event, Nothing), (event, Nothing)] handler + results `shouldBe` [Right (InboxProcessed ()), Right InboxDuplicate] + Right rowCount <- + Store.runStoreIO storeHandle $ + Store.runTransaction (Tx.statement () inboxTestCounterCountStmt) + rowCount `shouldBe` 1 + + it "falls back per message when one batch handler throws" $ \storeHandle -> do + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction (Tx.sql "CREATE TABLE IF NOT EXISTS inbox_test_counter (message_id TEXT PRIMARY KEY)") + let events = + [ sampleIntegrationEnvelope + & #messageId + .~ ("inbox-batch-poison-" <> Text.pack (show n)) + & #source + .~ "batch-ordering" + | n <- [1 .. 5 :: Int] + ] + handler ev + | ev ^. #messageId == "inbox-batch-poison-3" = + (pure $! error "batch poison") :: Tx.Transaction () + | otherwise = + Tx.statement (ev ^. #messageId) inboxTestCounterInsertStmt + Right results <- + Store.runStoreIO storeHandle $ + runInboxTransactionBatch Nothing 3 PreferIntegrationMessageId PersistFullEnvelope ((,Nothing) <$> events) handler + case results of + [ Right (InboxProcessed ()), + Right (InboxProcessed ()), + Right (InboxHandlerFailed err 1), + Right (InboxProcessed ()), + Right (InboxProcessed ()) + ] -> + Text.isInfixOf "batch poison" err `shouldBe` True + other -> expectationFailure ("unexpected batch fallback results: " <> show other) + Right rowCount <- + Store.runStoreIO storeHandle $ + Store.runTransaction (Tx.statement () inboxTestCounterCountStmt) + rowCount `shouldBe` 4 + Right (Just row) <- Store.runStoreIO storeHandle (lookupInbox "batch-ordering" "inbox-batch-poison-3") + row ^. #status `shouldBe` InboxFailed + row ^. #attemptCount `shouldBe` 1 + row ^. #lastError `shouldSatisfy` maybe False (Text.isInfixOf "batch poison") + + it "reports duplicates across batch calls" $ \storeHandle -> do + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction (Tx.sql "CREATE TABLE IF NOT EXISTS inbox_test_counter (message_id TEXT PRIMARY KEY)") + let event = + sampleIntegrationEnvelope + & #messageId + .~ "inbox-batch-existing-dup" + & #source + .~ "batch-ordering" + handler ev = Tx.statement (ev ^. #messageId) inboxTestCounterInsertStmt + Right first <- + Store.runStoreIO storeHandle $ + runInboxTransactionBatch Nothing 3 PreferIntegrationMessageId PersistFullEnvelope [(event, Nothing)] handler + first `shouldBe` [Right (InboxProcessed ())] + Right second <- + Store.runStoreIO storeHandle $ + runInboxTransactionBatch Nothing 3 PreferIntegrationMessageId PersistFullEnvelope [(event, Nothing)] handler + second `shouldBe` [Right InboxDuplicate] + Right rowCount <- + Store.runStoreIO storeHandle $ + Store.runTransaction (Tx.statement () inboxTestCounterCountStmt) + rowCount `shouldBe` 1 + + it "falls back per message when one batch handler condemns the transaction" $ \storeHandle -> do + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction (Tx.sql "CREATE TABLE IF NOT EXISTS inbox_test_counter (message_id TEXT PRIMARY KEY)") + let events = + [ sampleIntegrationEnvelope + & #messageId + .~ ("inbox-batch-condemn-" <> Text.pack (show n)) + & #source + .~ "batch-ordering" + | n <- [1 .. 3 :: Int] + ] + handler ev + | ev ^. #messageId == "inbox-batch-condemn-2" = Tx.condemn + | otherwise = Tx.statement (ev ^. #messageId) inboxTestCounterInsertStmt + Right results <- + Store.runStoreIO storeHandle $ + runInboxTransactionBatch Nothing 3 PreferIntegrationMessageId PersistFullEnvelope ((,Nothing) <$> events) handler + -- The condemned single-message retry reports processed by the + -- documented single-path contract; what matters is that the + -- innocent batch mates actually committed. + results `shouldBe` replicate 3 (Right (InboxProcessed ())) + Right rowCount <- + Store.runStoreIO storeHandle $ + Store.runTransaction (Tx.statement () inboxTestCounterCountStmt) + rowCount `shouldBe` 2 + Right (Just mate1) <- Store.runStoreIO storeHandle (lookupInbox "batch-ordering" "inbox-batch-condemn-1") + Right (Just mate3) <- Store.runStoreIO storeHandle (lookupInbox "batch-ordering" "inbox-batch-condemn-3") + mate1 ^. #status `shouldBe` InboxCompleted + mate3 ^. #status `shouldBe` InboxCompleted + Right condemned <- Store.runStoreIO storeHandle (lookupInbox "batch-ordering" "inbox-batch-condemn-2") + condemned `shouldBe` Nothing + + it "classifies a legacy processing row as InboxInProgress without running the handler" $ \storeHandle -> do + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction (Tx.sql "CREATE TABLE IF NOT EXISTS inbox_test_counter (message_id TEXT PRIMARY KEY)") + let event = + sampleIntegrationEnvelope + & #messageId + .~ "inbox-legacy-processing" + & #source + .~ "ordering" + handler ev = Tx.statement (ev ^. #messageId) inboxTestCounterInsertStmt + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + Tx.sql "INSERT INTO keiro.keiro_inbox (source, dedupe_key, content_type, payload_bytes, status) VALUES ('ordering', 'inbox-legacy-processing', 'application/json', ''::bytea, 'processing')" + Right result <- + Store.runStoreIO storeHandle $ + runInboxTransaction Nothing PreferIntegrationMessageId event Nothing handler + result `shouldBe` Right InboxInProgress + Right rowCount <- + Store.runStoreIO storeHandle $ + Store.runTransaction (Tx.statement () inboxTestCounterCountStmt) + rowCount `shouldBe` 0 + Right (Just row) <- Store.runStoreIO storeHandle (lookupInbox "ordering" "inbox-legacy-processing") + row ^. #status `shouldBe` InboxProcessing + + it "runs the handler once when two workers race the same dedupe key" $ \storeHandle -> do + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction (Tx.sql "CREATE TABLE IF NOT EXISTS inbox_test_counter (message_id TEXT PRIMARY KEY)") + let event = + sampleIntegrationEnvelope + & #messageId + .~ "inbox-race-dup" + & #source + .~ "ordering" + slowHandler ev = do + Tx.statement (ev ^. #messageId) inboxTestCounterInsertStmt + Tx.sql "SELECT pg_sleep(1.5)" + fastHandler ev = Tx.statement (ev ^. #messageId) inboxTestCounterInsertStmt + firstDone <- newEmptyMVar + _ <- forkIO $ do + first <- + Store.runStoreIO storeHandle $ + runInboxTransaction Nothing PreferIntegrationMessageId event Nothing slowHandler + putMVar firstDone first + -- Let the slow worker insert its uncommitted row, then race the + -- same dedupe key: the second insert must block on the unique + -- constraint until the first commits, then classify as duplicate. + threadDelay 400000 + Right second <- + Store.runStoreIO storeHandle $ + runInboxTransaction Nothing PreferIntegrationMessageId event Nothing fastHandler + Right first <- takeMVar firstDone + first `shouldBe` Right (InboxProcessed ()) + second `shouldBe` Right InboxDuplicate + Right rowCount <- + Store.runStoreIO storeHandle $ + Store.runTransaction (Tx.statement () inboxTestCounterCountStmt) + rowCount `shouldBe` 1 + + it "can persist only dedupe columns for successful rows" $ \storeHandle -> do + let kafka = KafkaDeliveryRef "billing.orders.v1" 1 42 + event = + sampleIntegrationEnvelope + & #messageId + .~ "inbox-slim-success" + & #source + .~ "ordering" + & #payloadBytes + .~ "full success payload" + & #attributes + ?~ object ["source" Aeson..= ("slim-test" :: Text)] + handler _ = pure () + Right (Right (InboxProcessed ())) <- + Store.runStoreIO storeHandle $ + runInboxTransactionWith Nothing PersistDedupeOnly PreferIntegrationMessageId event (Just kafka) handler + Right (Just row) <- Store.runStoreIO storeHandle (lookupInbox "ordering" "inbox-slim-success") + row ^. #event . #payloadBytes `shouldBe` "" + row ^. #event . #attributes `shouldBe` Nothing + row ^. #event . #traceContext `shouldBe` Nothing + row ^. #event . #schemaReference `shouldBe` Nothing + row ^. #event . #messageId `shouldBe` "inbox-slim-success" + row ^. #event . #sourceEventId `shouldBe` event ^. #sourceEventId + row ^. #event . #sourceGlobalPosition `shouldBe` event ^. #sourceGlobalPosition + row ^. #event . #causationId `shouldBe` event ^. #causationId + row ^. #event . #correlationId `shouldBe` event ^. #correlationId + row ^. #event . #occurredAt `shouldBe` event ^. #occurredAt + row ^. #kafka `shouldBe` Just kafka + Right redelivery <- + Store.runStoreIO storeHandle $ + runInboxTransactionWith Nothing PersistDedupeOnly PreferIntegrationMessageId event (Just kafka) handler + redelivery `shouldBe` Right InboxDuplicate + + it "keeps full failed rows even when successful rows are dedupe-only" $ \storeHandle -> do + let event = + sampleIntegrationEnvelope + & #messageId + .~ "inbox-slim-failed" + & #source + .~ "ordering" + & #payloadBytes + .~ "full failed payload" + & #attributes + ?~ object ["source" Aeson..= ("failed-slim-test" :: Text)] + handler _ = (pure $! error "slim failure") :: Tx.Transaction () + Right result <- + Store.runStoreIO storeHandle $ + runInboxTransactionWithRetriesWith Nothing 3 PersistDedupeOnly PreferIntegrationMessageId event Nothing handler + case result of + Right (InboxHandlerFailed err 1) -> + Text.isInfixOf "slim failure" err `shouldBe` True + other -> expectationFailure ("expected InboxHandlerFailed, got " <> show other) + Right (Just row) <- Store.runStoreIO storeHandle (lookupInbox "ordering" "inbox-slim-failed") + row ^. #status `shouldBe` InboxFailed + row ^. #event . #payloadBytes `shouldBe` event ^. #payloadBytes + row ^. #event . #attributes `shouldBe` event ^. #attributes + row ^. #event . #traceContext `shouldBe` event ^. #traceContext + row ^. #event . #schemaReference `shouldBe` event ^. #schemaReference + + it "garbage-collects completed rows older than the retention window" $ \storeHandle -> do + let event = + sampleIntegrationEnvelope + & #messageId + .~ "inbox-msg-gc" + & #source + .~ "ordering" + handler _ = pure () + Right (Right (InboxProcessed ())) <- + Store.runStoreIO storeHandle $ + runInboxTransaction Nothing PreferIntegrationMessageId event Nothing handler + -- Backdate the row so it falls outside the retention window. + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + Tx.sql + "UPDATE keiro.keiro_inbox SET completed_at = now() - interval '40 days' WHERE message_id = 'inbox-msg-gc'" + now <- getCurrentTime + Right deleted <- Store.runStoreIO storeHandle (garbageCollectCompleted (nominalDays 30) now) + deleted `shouldBe` 1 + Right rows <- Store.runStoreIO storeHandle (listInbox "ordering") + rows `shouldBe` [] + + describe "Keiro.Inbox.Kafka" $ do + it "reconstructs an integration event from headers and payload" $ do + let envelope = sampleIntegrationEnvelope + headers = integrationHeaders envelope + receivedAt = addUTCTime 60 (envelope ^. #occurredAt) + record = + InboxKafka.KafkaInboundRecord + { topic = "billing.orders.v1", + partition = 2, + offset = 113, + key = Just "order-123", + payload = envelope ^. #payloadBytes, + headers, + receivedAt + } + case InboxKafka.integrationEventFromKafka record of + Right (rebuilt, kafkaRef) -> do + rebuilt ^. #messageId `shouldBe` envelope ^. #messageId + rebuilt ^. #source `shouldBe` envelope ^. #source + rebuilt ^. #destination `shouldBe` envelope ^. #destination + rebuilt ^. #eventType `shouldBe` envelope ^. #eventType + rebuilt ^. #schemaVersion `shouldBe` envelope ^. #schemaVersion + rebuilt ^. #sourceEventId `shouldBe` envelope ^. #sourceEventId + rebuilt ^. #sourceGlobalPosition `shouldBe` envelope ^. #sourceGlobalPosition + rebuilt ^. #payloadBytes `shouldBe` envelope ^. #payloadBytes + rebuilt ^. #occurredAt `shouldBe` envelope ^. #occurredAt + rebuilt ^. #attributes `shouldBe` envelope ^. #attributes + kafkaRef ^. #topic `shouldBe` "billing.orders.v1" + kafkaRef ^. #partition `shouldBe` 2 + kafkaRef ^. #offset `shouldBe` 113 + Left err -> expectationFailure ("expected Right, got Left " <> show err) + + it "falls back to receivedAt when the occurredAt header is absent" $ do + let envelope = sampleIntegrationEnvelope + receivedAt = addUTCTime 60 (envelope ^. #occurredAt) + headers = filter ((/= "keiro-occurred-at") . Prelude.fst) (integrationHeaders envelope) + record = + InboxKafka.KafkaInboundRecord + { topic = "billing.orders.v1", + partition = 2, + offset = 113, + key = Just "order-123", + payload = envelope ^. #payloadBytes, + headers, + receivedAt + } + case InboxKafka.integrationEventFromKafka record of + Right (rebuilt, _) -> rebuilt ^. #occurredAt `shouldBe` receivedAt + Left err -> expectationFailure ("expected Right, got Left " <> show err) + + it "rejects malformed occurredAt headers" $ do + let envelope = sampleIntegrationEnvelope + headers = ("keiro-occurred-at", "not-a-time") : filter ((/= "keiro-occurred-at") . Prelude.fst) (integrationHeaders envelope) + record = + InboxKafka.KafkaInboundRecord + { topic = "billing.orders.v1", + partition = 2, + offset = 113, + key = Just "order-123", + payload = envelope ^. #payloadBytes, + headers, + receivedAt = envelope ^. #occurredAt + } + InboxKafka.integrationEventFromKafka record + `shouldBe` Left (InboxKafka.InvalidTimeHeader "keiro-occurred-at" "not-a-time") + + it "reports MissingHeader for an essential header" $ do + let envelope = sampleIntegrationEnvelope + headers = filter ((/= "keiro-message-id") . Prelude.fst) (integrationHeaders envelope) + record = + InboxKafka.KafkaInboundRecord + { topic = "billing.orders.v1", + partition = 0, + offset = 0, + key = Nothing, + payload = envelope ^. #payloadBytes, + headers, + receivedAt = envelope ^. #occurredAt + } + InboxKafka.integrationEventFromKafka record + `shouldBe` Left (InboxKafka.MissingHeader "keiro-message-id") + + it "withConsumerSpan parents the consumer span under an upstream producer span via W3C headers" $ do + (processor, spansRef) <- inMemoryListExporter + provider <- createTracerProvider [processor] emptyTracerProviderOptions + let tracer = makeTracer provider "keiro-test" tracerOptions + -- Clear the baked-in TraceContext on the sample so the only + -- `traceparent` on the wire comes from the active producer + -- span (via `injectTraceContext`). + envelope = sampleIntegrationEnvelope & #traceContext .~ Nothing + producerRecord = OutboxKafka.integrationEventToKafkaRecord envelope + producerHeadersText <- + Telemetry.withProducerSpan (Just tracer) envelope producerRecord $ \_ -> do + let baseHeaders = + [(TE.decodeUtf8 n, TE.decodeUtf8 v) | (n, v) <- producerRecord ^. #headers] + Telemetry.injectTraceContext baseHeaders + -- Build the inbound record the consumer would receive and open the + -- consumer span around a no-op body. + now <- getCurrentTime + let inbound = + InboxKafka.KafkaInboundRecord + { topic = envelope ^. #destination, + partition = 7, + offset = 42, + key = envelope ^. #key, + payload = envelope ^. #payloadBytes, + headers = producerHeadersText, + receivedAt = now + } + Telemetry.withConsumerSpan (Just tracer) (Just "billing-cg") inbound (Just envelope) $ \_ -> + pure () + _ <- shutdownTracerProvider provider Nothing + spans <- traverse captureSpan =<< readIORef spansRef + length spans `shouldBe` 2 + let findByName needle = case [s | s <- spans, csName s == needle] of + (s : _) -> s + [] -> error ("no span captured with name=" <> Text.unpack needle) + producerSp = findByName ("send " <> envelope ^. #destination) + consumerSp = findByName ("process " <> envelope ^. #destination) + -- Same trace id end-to-end (cross-process parenting). + traceId (csContext producerSp) `shouldBe` traceId (csContext consumerSp) + -- Consumer's parent is the producer span. + case csParent consumerSp of + Nothing -> expectationFailure "consumer span has no parent" + Just parent -> do + parentCtx <- getSpanContext parent + spanId parentCtx `shouldBe` spanId (csContext producerSp) + -- Consumer span carries the expected attributes. + show (csKind consumerSp) `shouldBe` "Consumer" + textAttr (csAttributes consumerSp) "messaging.system" `shouldBe` Just "kafka" + textAttr (csAttributes consumerSp) "messaging.operation.type" `shouldBe` Just "process" + textAttr (csAttributes consumerSp) "messaging.destination.name" + `shouldBe` Just (envelope ^. #destination) + textAttr (csAttributes consumerSp) "messaging.destination.partition.id" + `shouldBe` Just "7" + textAttr (csAttributes consumerSp) "messaging.consumer.group.name" + `shouldBe` Just "billing-cg" + textAttr (csAttributes consumerSp) "messaging.message.id" + `shouldBe` Just (envelope ^. #messageId) + + describe "Keiro cross-context Kafka integration" $ around (withFreshStores2 fixture) $ do + it "publishes an Ordering integration event and runs the Billing handler exactly once across duplicate deliveries" $ \(ordering, billing) -> do + Right () <- + Store.runStoreIO billing $ + Store.runTransaction (Tx.sql "CREATE TABLE IF NOT EXISTS billing_received_orders (order_id TEXT PRIMARY KEY, quantity BIGINT NOT NULL)") + topic <- newKafkaTopic + -- Ordering side: enqueue an outbox row representing a published event. + let orderingEvent = orderSubmittedEnvelope "order-aaa" 7 "msg-aaa" + oid = OutboxId outboxUuid1 + Right () <- + Store.runStoreIO ordering $ + Store.runTransaction (enqueueIntegrationEventTx oid orderingEvent) + -- Run the publisher worker: push records to the in-process topic. + Right pubSummary1 <- + Store.runStoreIO ordering $ + publishClaimedOutbox (perRow (kafkaTopicPublish topic)) defaultPublishOptions Nothing + pubSummary1 ^. #published `shouldBe` 1 + -- Billing side: consume from the topic. + records1 <- drainKafkaTopic topic + record1 <- case records1 of + [r] -> pure r + other -> expectationFailure ("expected 1 record, got " <> show (length other)) *> error "unreachable" + Right consumed1 <- + Store.runStoreIO billing $ + consumeAndApply record1 billingReactionHandler + consumed1 `shouldBe` ConsumeApplied (InboxProcessed ()) + Right rowCount1 <- + Store.runStoreIO billing $ + Store.runTransaction (Tx.statement () billingReceivedOrdersCountStmt) + rowCount1 `shouldBe` 1 + + -- Simulate Kafka redelivery: pretend the same Kafka record was + -- delivered again at a different offset. The producer also retries + -- (the outbox flips back to pending and the worker republishes). + let redelivered = redeliverWithDifferentOffset record1 + Right consumed2 <- + Store.runStoreIO billing $ + consumeAndApply redelivered billingReactionHandler + consumed2 `shouldBe` ConsumeApplied InboxDuplicate + Right rowCount2 <- + Store.runStoreIO billing $ + Store.runTransaction (Tx.statement () billingReceivedOrdersCountStmt) + rowCount2 `shouldBe` 1 + + it "preserves per-partition ordering for two events sharing a Kafka key" $ \(ordering, billing) -> do + Right () <- + Store.runStoreIO billing $ + Store.runTransaction (Tx.sql "CREATE TABLE IF NOT EXISTS billing_received_orders (order_id TEXT PRIMARY KEY, quantity BIGINT NOT NULL)") + Right () <- + Store.runStoreIO billing $ + Store.runTransaction (Tx.sql "CREATE TABLE IF NOT EXISTS billing_event_log (seq BIGSERIAL PRIMARY KEY, source TEXT NOT NULL, event_type TEXT NOT NULL, order_id TEXT NOT NULL)") + topic <- newKafkaTopic + -- Two events for the same order key. + let submittedEnv = orderSubmittedEnvelope "order-bbb" 4 "msg-bbb-1" + cancelledEnv = orderCancelledEnvelope "order-bbb" "msg-bbb-2" + submittedId = OutboxId outboxUuid1 + cancelledId = OutboxId outboxUuid2 + Right () <- + Store.runStoreIO ordering $ + Store.runTransaction (enqueueIntegrationEventTx submittedId submittedEnv) + Right () <- + Store.runStoreIO ordering $ + Store.runTransaction (enqueueIntegrationEventTx cancelledId cancelledEnv) + -- Run-claiming lets a same-key contiguous run drain in one pass. + let drainOnce = + publishClaimedOutbox + (perRow (kafkaTopicPublish topic)) + (defaultPublishOptions & #backoff .~ ConstantBackoff 0) + Nothing + Right s1 <- Store.runStoreIO ordering drainOnce + Right s2 <- Store.runStoreIO ordering drainOnce + (s1 ^. #published) + (s2 ^. #published) `shouldBe` 2 + records <- drainKafkaTopic topic + length records `shouldBe` 2 + -- Apply both records to billing in delivery order. + for_ records $ \record -> do + Right consumed <- + Store.runStoreIO billing $ + consumeAndApply record (loggingReactionHandler "billing") + case consumed of + ConsumeApplied (InboxProcessed ()) -> pure () + other -> expectationFailure ("expected processed, got " <> show other) + Right events <- + Store.runStoreIO billing $ + Store.runTransaction (Tx.statement () billingEventLogStmt) + events `shouldBe` [("OrderSubmitted", "order-bbb"), ("OrderCancelled", "order-bbb")] + + it "head-of-line blocks a same-key successor when the first send fails repeatedly until the first row reaches dead status" $ \(ordering, billing) -> do + Right () <- + Store.runStoreIO billing $ + Store.runTransaction (Tx.sql "CREATE TABLE IF NOT EXISTS billing_received_orders (order_id TEXT PRIMARY KEY, quantity BIGINT NOT NULL)") + topic <- newKafkaTopic + let submittedEnv = orderSubmittedEnvelope "order-ccc" 1 "msg-ccc-1" + cancelledEnv = orderCancelledEnvelope "order-ccc" "msg-ccc-2" + firstId = OutboxId outboxUuid1 + secondId = OutboxId outboxUuid2 + Right () <- + Store.runStoreIO ordering $ + Store.runTransaction (enqueueIntegrationEventTx firstId submittedEnv) + Right () <- + Store.runStoreIO ordering $ + Store.runTransaction (enqueueIntegrationEventTx secondId cancelledEnv) + -- Failing publish for the first row, success for any other. + let publish row + | row ^. #outboxId == firstId = + pure (PublishFailed "simulated broker reject") + | otherwise = do + kafkaTopicAccept topic row + pure PublishSucceeded + deadOpts = + defaultPublishOptions + & #batchSize + .~ 1 + & #backoff + .~ ConstantBackoff 0 + & #maxAttempts + .~ 2 + -- This test drives the pre-M3 sequential failure/dead-letter path + -- with one-row batches. M3 adds suffix skipping for larger claimed + -- same-key runs. + -- First pass: the first row attempts once and fails; the second is + -- outside the one-row claim window. + Right pass1 <- Store.runStoreIO ordering (publishClaimedOutbox (perRow publish) deadOpts Nothing) + pass1 ^. #retried `shouldBe` 1 + pass1 ^. #published `shouldBe` 0 + -- Second pass crosses maxAttempts and dead-letters the first row. + Right pass2 <- Store.runStoreIO ordering (publishClaimedOutbox (perRow publish) deadOpts Nothing) + pass2 ^. #dead `shouldBe` 1 + Right (Just firstRow) <- Store.runStoreIO ordering (lookupOutbox firstId) + firstRow ^. #status `shouldBe` OutboxDead + -- With the first row dead, the second becomes claimable and publishes. + Right pass3 <- Store.runStoreIO ordering (publishClaimedOutbox (perRow publish) deadOpts Nothing) + pass3 ^. #published `shouldBe` 1 + Right (Just secondRow) <- Store.runStoreIO ordering (lookupOutbox secondId) + secondRow ^. #status `shouldBe` OutboxSent + -- Billing only sees the second event. + records <- drainKafkaTopic topic + record <- case records of + [r] -> pure r + other -> expectationFailure ("expected 1 record, got " <> show (length other)) *> error "unreachable" + Right consumed <- + Store.runStoreIO billing $ + consumeAndApply record billingReactionHandler + consumed `shouldBe` ConsumeApplied (InboxProcessed ()) + + describe "Keiro.Integration.Event" $ do + it "round-trips a JSON envelope through encode and decode" $ do + let envelope = sampleIntegrationEnvelope + payload = OrderSubmittedPayload "order-123" 5 + encoded = encodeJsonIntegrationEvent envelope payload + decodeJsonIntegrationEvent encoded `shouldBe` Right payload + + it "preserves identity and routing through encode" $ do + let envelope = sampleIntegrationEnvelope + encoded = encodeJsonIntegrationEvent envelope (OrderSubmittedPayload "order-123" 5) + encoded ^. #messageId `shouldBe` envelope ^. #messageId + encoded ^. #source `shouldBe` "ordering" + encoded ^. #destination `shouldBe` "billing.orders.v1" + encoded ^. #key `shouldBe` Just "order-123" + encoded ^. #eventType `shouldBe` "OrderSubmitted" + encoded ^. #schemaVersion `shouldBe` 1 + encoded ^. #contentType `shouldBe` ApplicationJson + + it "emits the canonical wire headers" $ do + let envelope = sampleIntegrationEnvelope + headers = integrationHeaders envelope + Prelude.lookup headerMessageId headers `shouldBe` Just (envelope ^. #messageId) + Prelude.lookup headerSchemaVersion headers `shouldBe` Just "1" + Prelude.lookup headerContentType headers `shouldBe` Just "application/json" + Prelude.lookup headerSchemaSubject headers `shouldBe` Just "billing.orders.v1.OrderSubmitted" + Prelude.lookup headerSourceEventId headers `shouldBe` Just "018f0f18-17aa-7000-8000-000000000003" + Prelude.lookup headerSourceGlobalPosition headers `shouldBe` Just "42" + Prelude.lookup headerTraceParent headers + `shouldBe` Just "00-0af7651916cd43dd8448eb211c80319c-b7ad6b7169203331-01" + + it "preserves a different content type without claiming JSON" $ do + let envelope = + sampleIntegrationEnvelope + & #contentType + .~ OtherContentType "application/vnd.apache.avro.binary" + & #payloadBytes + .~ "\x00\x01\x02" + headers = integrationHeaders envelope + Prelude.lookup headerContentType headers + `shouldBe` Just "application/vnd.apache.avro.binary" + decodeJsonIntegrationEvent envelope + `shouldBe` ( Left (IntegrationEvent.UnsupportedContentType "application/vnd.apache.avro.binary") :: + Either IntegrationEvent.IntegrationEventError OrderSubmittedPayload + ) + + it "reports malformed JSON payloads as decode errors instead of throwing" $ do + let envelope = + sampleIntegrationEnvelope + & #payloadBytes + .~ "{not-json" + case decodeJsonIntegrationEvent envelope :: Either IntegrationEvent.IntegrationEventError OrderSubmittedPayload of + Left (IntegrationEvent.MalformedPayload _) -> pure () + other -> expectationFailure ("expected MalformedPayload, got " <> show other) + + it "reports a JSON value that does not satisfy the target type as DecodeFailed" $ do + let envelope = + sampleIntegrationEnvelope + & #payloadBytes + .~ "{\"orderId\":\"order-123\"}" + case decodeJsonIntegrationEvent envelope :: Either IntegrationEvent.IntegrationEventError OrderSubmittedPayload of + Left (IntegrationEvent.DecodeFailed _) -> pure () + other -> expectationFailure ("expected DecodeFailed, got " <> show other) + + it "parses content-type headers back to the canonical type" $ do + parseContentType "application/json" `shouldBe` ApplicationJson + parseContentType "Application/JSON" `shouldBe` ApplicationJson + parseContentType "application/json; charset=utf-8" `shouldBe` ApplicationJson + parseContentType "APPLICATION/JSON ; CHARSET=UTF-8" `shouldBe` ApplicationJson + parseContentType "application/vnd.apache.avro.binary" + `shouldBe` OtherContentType "application/vnd.apache.avro.binary" + + it "preserves the payload bytes through integrationPayload" $ do + let envelope = sampleIntegrationEnvelope + encoded = encodeJsonIntegrationEvent envelope (OrderSubmittedPayload "order-123" 5) + integrationPayload encoded `shouldBe` (encoded ^. #payloadBytes) + + describe "Keiro.Telemetry" $ do + it "is a pass-through under a noop (Nothing) tracer" $ do + counter <- newIORef (0 :: Int) + let envelope = sampleIntegrationEnvelope + record = OutboxKafka.integrationEventToKafkaRecord envelope + result <- + Telemetry.withProducerSpan Nothing envelope record $ \mSpan -> do + atomicModifyIORef' counter (\n -> (n + 1, ())) + pure (mSpan, "ok" :: Text) + callsAfter <- readIORef counter + callsAfter `shouldBe` (1 :: Int) + snd result `shouldBe` "ok" + fst result `shouldSatisfy` isNothing + + it "re-exports AttributeKeys whose textual payload matches the spec name" $ do + attrKeyText Telemetry.messaging_operation_type `shouldBe` "messaging.operation.type" + attrKeyText Telemetry.messaging_operation_name `shouldBe` "messaging.operation.name" + attrKeyText Telemetry.messaging_destination_partition_id `shouldBe` "messaging.destination.partition.id" + attrKeyText Telemetry.messaging_consumer_group_name `shouldBe` "messaging.consumer.group.name" + attrKeyText Telemetry.messaging_client_id `shouldBe` "messaging.client.id" + attrKeyTextInt64 Telemetry.messaging_kafka_offset `shouldBe` "messaging.kafka.offset" + attrKeyText Telemetry.db_system_name `shouldBe` "db.system.name" + attrKeyText Telemetry.db_namespace `shouldBe` "db.namespace" + attrKeyText Telemetry.db_collection_name `shouldBe` "db.collection.name" + attrKeyText Telemetry.db_operation_name `shouldBe` "db.operation.name" + attrKeyText Telemetry.keiro_stream_name `shouldBe` "keiro.stream.name" + attrKeyTextInt64 Telemetry.keiro_retry_attempt `shouldBe` "keiro.retry.attempt" + attrKeyTextInt64 Telemetry.keiro_events_appended `shouldBe` "keiro.events.appended" + attrKeyText Telemetry.keiro_replay_divergence `shouldBe` "keiro.replay.divergence" + + it "extracts a TraceContext from a W3C traceparent header pair" $ do + let traceparent = "00-0af7651916cd43dd8448eb211c80319c-b7ad6b7169203331-01" + tracestate = "vendor1=value1" + hs = [(headerTraceParent, traceparent), ("tracestate", tracestate)] + Telemetry.traceContextFromHeaders hs + `shouldBe` Just (TraceContext traceparent (Just tracestate)) + + it "returns Nothing when the traceparent header is missing" $ do + Telemetry.traceContextFromHeaders [("content-type", "application/json")] + `shouldBe` Nothing + + it "injectTraceContext is a no-op when no span is active on the thread" $ do + let baseline = [("content-type", "application/json")] + injected <- Telemetry.injectTraceContext baseline + injected `shouldBe` baseline + + it "traceContextFromCurrentSpan returns Nothing outside any span" $ do + tc <- Telemetry.traceContextFromCurrentSpan + tc `shouldBe` Nothing + + describe "Keiro.Workflow" $ around (withFreshStore fixture) $ do + it "journals each step once, returns Completed, and runs each side effect once" $ \storeHandle -> do + counter <- newIORef (0 :: Int) + let name = WorkflowName "demo" + wid = WorkflowId "demo-1" + result <- Store.runStoreIO storeHandle $ runWorkflow name wid (demoWorkflow counter) + result `shouldBe` Right (Completed (1, 2)) + sideEffects <- readIORef counter + sideEffects `shouldBe` 2 + Right recorded <- + Store.runStoreIO storeHandle $ + Store.readStreamForward (StreamName "wf:demo-demo-1") (StreamVersion 0) 10 + Vector.length recorded `shouldBe` 3 + traverse (decodeRecorded workflowJournalCodec) (Vector.toList recorded) + `shouldSatisfy` \case + Right [StepRecorded "first" _ _, StepRecorded "second" _ _, WorkflowCompleted _] -> True + _ -> False + + it "replays recorded steps without re-running their side effects" $ \storeHandle -> do + counter <- newIORef (0 :: Int) + let name = WorkflowName "replay" + wid = WorkflowId "r-1" + first <- Store.runStoreIO storeHandle $ runWorkflow name wid (demoWorkflow counter) + first `shouldBe` Right (Completed (1, 2)) + afterFirst <- readIORef counter + afterFirst `shouldBe` 2 + -- A second run with the same id is exactly the crash-restart scenario. + second <- Store.runStoreIO storeHandle $ runWorkflow name wid (demoWorkflow counter) + second `shouldBe` Right (Completed (1, 2)) + afterSecond <- readIORef counter + afterSecond `shouldBe` 2 + -- The deterministic ids and pre-load gating leave the journal at 3 events. + Right recorded <- + Store.runStoreIO storeHandle $ + Store.readStreamForward (StreamName "wf:replay-r-1") (StreamVersion 0) 10 + Vector.length recorded `shouldBe` 3 + + it "reuses the recorded result for a repeated step name in one run" $ \storeHandle -> do + counter <- newIORef (0 :: Int) + let name = WorkflowName "samename" + wid = WorkflowId "s-1" + duplicateStepWorkflow = do + a <- step (StepName "dup") (liftIO (incrementAndRead counter)) + b <- step (StepName "dup") (liftIO (incrementAndRead counter)) + pure (a, b) + result <- Store.runStoreIO storeHandle $ runWorkflow name wid duplicateStepWorkflow + result `shouldBe` Right (Completed (1, 1)) + sideEffects <- readIORef counter + sideEffects `shouldBe` 1 + + it "suspends on an unresolved awaitStep, journaling no completion" $ \storeHandle -> do + let name = WorkflowName "awaiter" + wid = WorkflowId "a-1" + result <- Store.runStoreIO storeHandle $ runWorkflow name wid neverArmingWorkflow + result `shouldBe` Right Suspended + Right recorded <- + Store.runStoreIO storeHandle $ + Store.readStreamForward (StreamName "wf:awaiter-a-1") (StreamVersion 0) 10 + Vector.length recorded `shouldBe` 0 + + it "resumes and completes once an awaited step is externally completed" $ \storeHandle -> do + let name = WorkflowName "awaiter2" + wid = WorkflowId "a-2" + suspended <- Store.runStoreIO storeHandle $ runWorkflow name wid neverArmingWorkflow + suspended `shouldBe` Right Suspended + -- Simulate a wake source recording the awaited step's resolution. + Right () <- Store.runStoreIO storeHandle $ do + now <- liftIO getCurrentTime + appendJournalEntry name wid (StepRecorded "awk:test" (toJSON (42 :: Int)) now) + resumed <- Store.runStoreIO storeHandle $ runWorkflow name wid neverArmingWorkflow + resumed `shouldBe` Right (Completed 42) + Right recorded <- + Store.runStoreIO storeHandle $ + Store.readStreamForward (StreamName "wf:awaiter2-a-2") (StreamVersion 0) 10 + traverse (decodeRecorded workflowJournalCodec) (Vector.toList recorded) + `shouldSatisfy` \case + Right [StepRecorded "awk:test" _ _, WorkflowCompleted _] -> True + _ -> False + + it "treats a duplicate external journal append as idempotent" $ \storeHandle -> do + let name = WorkflowName "duplicate-append" + wid = WorkflowId "da-1" + stepKey = "awk:test" + eventAt t = StepRecorded stepKey (toJSON (42 :: Int)) t + now <- getCurrentTime + Right firstId <- + Store.runStoreIO storeHandle $ + appendJournalEntryReturningId name wid (eventAt now) + secondResult <- + Store.runStoreIO storeHandle $ + appendJournalEntryReturningId name wid (eventAt now) + secondId <- case secondResult of + Right value -> pure value + Left err -> expectationFailure ("expected idempotent duplicate append, got " <> show err) *> error "unreachable" + secondId `shouldBe` firstId + Right indexed <- Store.runStoreIO storeHandle $ loadStepIndex name wid 0 + Map.lookup stepKey indexed `shouldBe` Just (toJSON (42 :: Int)) + Right recorded <- + Store.runStoreIO storeHandle $ + Store.readStreamForward (StreamName "wf:duplicate-append-da-1") (StreamVersion 0) 10 + Vector.length recorded `shouldBe` 1 + + it "returns the journaled value when another writer records the same step mid-flight" $ \storeHandle -> do + let name = WorkflowName "journal-race" + wid = WorkflowId "jr-1" + body = + step (StepName "raced") $ do + now <- liftIO getCurrentTime + appendJournalEntry name wid (StepRecorded "raced" (toJSON ("winner" :: Text)) now) + pure ("loser" :: Text) + outcome <- Store.runStoreIO storeHandle $ runWorkflow name wid body + outcome `shouldBe` Right (Completed "winner") + Right recorded <- + Store.runStoreIO storeHandle $ + Store.readStreamForward (StreamName "wf:journal-race-jr-1") (StreamVersion 0) 10 + traverse (decodeRecorded workflowJournalCodec) (Vector.toList recorded) + `shouldSatisfy` \case + Right [StepRecorded "raced" value _, WorkflowCompleted _] -> value == toJSON ("winner" :: Text) + _ -> False + + it "returns the JSON round-trip of a fresh step result" $ \storeHandle -> do + let name = WorkflowName "roundtrip-step" + wid = WorkflowId "rs-1" + body = step (StepName "approx") (pure (Approx 1.7)) + first <- Store.runStoreIO storeHandle $ runWorkflow name wid body + first `shouldBe` Right (Completed (Approx 2.0)) + replay <- Store.runStoreIO storeHandle $ runWorkflow name wid body + replay `shouldBe` Right (Completed (Approx 2.0)) + + it "throws WorkflowStepDecodeError on the first run when the recorded result cannot decode" $ \storeHandle -> do + let name = WorkflowName "bad-roundtrip" + wid = WorkflowId "br-1" + body = step (StepName "bad") (pure RejectingRoundTrip) + Store.runStoreIO storeHandle (runWorkflow name wid body) + `shouldThrow` \case + WorkflowStepDecodeError key _ -> key == "bad" + _ -> False + Store.runStoreIO storeHandle (stepExists name wid 0 "bad") + `shouldReturn` Right True + + it "discovers unfinished workflows via the step index" $ \storeHandle -> do + counter <- newIORef (0 :: Int) + Right (Completed _) <- + Store.runStoreIO storeHandle $ + runWorkflow (WorkflowName "done") (WorkflowId "d-1") (demoWorkflow counter) + Right Suspended <- + Store.runStoreIO storeHandle $ + runWorkflow (WorkflowName "pending") (WorkflowId "p-1") (stepThenAwaitWorkflow counter) + now <- getCurrentTime + Right unfinished <- Store.runStoreIO storeHandle (findUnfinishedWorkflowIds now) + unfinished `shouldBe` [("p-1", "pending")] + + describe "Keiro.Workflow instance table" $ around (withFreshStore fixture) $ do + it "creates and completes a workflow instance row transactionally with the journal" $ \storeHandle -> do + counter <- newIORef (0 :: Int) + let name = WorkflowName "inst-complete" + wid = WorkflowId "ic-1" + Right (Completed _) <- Store.runStoreIO storeHandle $ runWorkflow name wid (demoWorkflow counter) + Right (Just row) <- Store.runStoreIO storeHandle $ Instance.lookupInstance name wid + row ^. #workflowId `shouldBe` "ic-1" + row ^. #workflowName `shouldBe` "inst-complete" + row ^. #generation `shouldBe` 0 + row ^. #status `shouldBe` Instance.WfCompleted + row ^. #completedAt `shouldSatisfy` isJust + + it "records suspended status for workflows that park before journaling" $ \storeHandle -> do + let name = WorkflowName "inst-suspended" + wid = WorkflowId "is-1" + Right Suspended <- Store.runStoreIO storeHandle $ runWorkflow name wid neverArmingWorkflow + Right (Just row) <- Store.runStoreIO storeHandle $ Instance.lookupInstance name wid + row ^. #status `shouldBe` Instance.WfSuspended + row ^. #generation `shouldBe` 0 + row ^. #completedAt `shouldBe` Nothing + + it "creates child instance rows at spawn time and flips them to cancelled" $ \storeHandle -> do + let childWid = WorkflowId "inst-child" + childName = WorkflowName "ship" + Right Suspended <- + Store.runStoreIO storeHandle $ + runWorkflow (WorkflowName "inst-parent") (WorkflowId "ip-1") (parentWorkflow childWid) + Right (Just spawned) <- Store.runStoreIO storeHandle $ Instance.lookupInstance childName childWid + spawned ^. #status `shouldBe` Instance.WfRunning + Right True <- Store.runStoreIO storeHandle $ cancelChild (ChildHandle childName childWid) + Right (Just cancelledRow) <- Store.runStoreIO storeHandle $ Instance.lookupInstance childName childWid + cancelledRow ^. #status `shouldBe` Instance.WfCancelled + cancelledRow ^. #completedAt `shouldSatisfy` isJust + + it "bumps the instance generation when continueAsNew rotates" $ \storeHandle -> do + counter <- newIORef (0 :: Int) + let name = WorkflowName "inst-rotate" + wid = WorkflowId "ir-1" + Right ContinuedAsNew <- + Store.runStoreIO storeHandle $ + runWorkflow name wid (rollingTotal counter 1 2) + Right (Just row) <- Store.runStoreIO storeHandle $ Instance.lookupInstance name wid + row ^. #generation `shouldBe` 1 + row ^. #status `shouldBe` Instance.WfRunning + + it "does not let a late append resurrect a terminal instance row" $ \storeHandle -> do + counter <- newIORef (0 :: Int) + let name = WorkflowName "inst-terminal" + wid = WorkflowId "it-1" + Right (Completed _) <- Store.runStoreIO storeHandle $ runWorkflow name wid (demoWorkflow counter) + now <- getCurrentTime + Right () <- + Store.runStoreIO storeHandle $ + appendJournalEntry name wid (StepRecorded "late" (toJSON True) now) + Right (Just row) <- Store.runStoreIO storeHandle $ Instance.lookupInstance name wid + row ^. #status `shouldBe` Instance.WfCompleted + + it "discovers unfinished workflows from the instance table" $ \storeHandle -> do + counter <- newIORef (0 :: Int) + let completedName = WorkflowName "discover-completed" + cancelledName = WorkflowName "discover-cancelled" + crashedName = WorkflowName "discover-crashed" + rotatedName = WorkflowName "discover-rotated" + Right (Completed _) <- + Store.runStoreIO storeHandle $ + runWorkflow completedName (WorkflowId "done") (demoWorkflow counter) + cancelledAt <- getCurrentTime + Right () <- + Store.runStoreIO storeHandle $ + appendJournalEntry cancelledName (WorkflowId "cancelled") (WorkflowCancelled cancelledAt) + Left (_ :: SimulatedCrash) <- + try $ + Store.runStoreIO storeHandle $ + runWorkflow crashedName (WorkflowId "crashed") (crashAfterStep1 counter) + Right ContinuedAsNew <- + Store.runStoreIO storeHandle $ + runWorkflow rotatedName (WorkflowId "rotated") (rollingTotal counter 1 2) + now <- getCurrentTime + Right unfinished <- Store.runStoreIO storeHandle (findUnfinishedWorkflowIds now) + unfinished + `shouldBe` [ ("crashed", "discover-crashed"), + ("rotated", "discover-rotated") + ] + + describe "Keiro.Workflow snapshots" $ around (withFreshStore fixture) $ do + it "does not fail committed workflow steps when snapshot writes fail" $ \storeHandle -> do + (exporter, metricsRef) <- inMemoryMetricExporter + (provider, _env) <- + createMeterProvider + emptyMaterializedResources + defaultSdkMeterProviderOptions {metricExporter = Just exporter} + meter <- getMeter provider Telemetry.keiroInstrumentationLibrary + keiroMetrics <- Telemetry.newKeiroMetrics meter + let opts = + defaultWorkflowRunOptions + & #snapshotPolicy + .~ Every 2 + & #metrics + ?~ keiroMetrics + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + Tx.sql "ALTER TABLE keiro.keiro_snapshots ADD CONSTRAINT keiro_snapshots_no_writes CHECK (false) NOT VALID" + counter <- newIORef (0 :: Int) + result <- + Store.runStoreIO storeHandle $ + runWorkflowWith opts (WorkflowName "snap-write-failure") (WorkflowId "wf1") (countingSixSteps counter) + result `shouldBe` Right (Completed [1, 2, 3, 4, 5, 6]) + Right journal <- + Store.runStoreIO storeHandle $ + Store.readStreamForward (StreamName "wf:snap-write-failure-wf1") (StreamVersion 0) 100 + Vector.length journal `shouldBe` 7 + Right snapshotVersionDuringFailure <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + Tx.statement "wf:snap-write-failure-wf1" snapshotVersionForStreamStmt + snapshotVersionDuringFailure `shouldBe` Nothing + _ <- forceFlushMeterProvider provider Nothing + exported <- readIORef metricsRef + lookup "keiro.snapshot.write.failures" (flattenScalarPoints exported) `shouldBe` Just (IntNumber 3) + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + Tx.sql "ALTER TABLE keiro.keiro_snapshots DROP CONSTRAINT keiro_snapshots_no_writes" + recoveryCounter <- newIORef (0 :: Int) + recovery <- + Store.runStoreIO storeHandle $ + runWorkflowWith opts (WorkflowName "snap-write-recovery") (WorkflowId "wf2") (countingSixSteps recoveryCounter) + recovery `shouldBe` Right (Completed [1, 2, 3, 4, 5, 6]) + Right snapshotVersionAfterRecovery <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + Tx.statement "wf:snap-write-recovery-wf2" snapshotVersionForStreamStmt + snapshotVersionAfterRecovery `shouldBe` Just (StreamVersion 6) + + -- Validation (a): a snapshot row appears at the expected version and + -- decodes to the full accumulated step map. + it "writes a snapshot of the accumulated step map after Every 2 fires" $ \storeHandle -> do + counter <- newIORef (0 :: Int) + let name = WorkflowName "snap" + wid = WorkflowId "w1" + result <- + Store.runStoreIO storeHandle $ + runWorkflowWith + (defaultWorkflowRunOptions & #snapshotPolicy .~ Every 2) + name + wid + (countingSixSteps counter) + result `shouldBe` Right (Completed [1, 2, 3, 4, 5, 6]) + -- Every 2 fired at versions 2, 4, 6; the upsert keeps the highest (6). + Right snapVersion <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + Tx.statement "wf:snap-w1" snapshotVersionForStreamStmt + snapVersion `shouldBe` Just (StreamVersion 6) + -- and the row decodes to the six-entry accumulated map. + Right mSeed <- Store.runStoreIO storeHandle $ loadWorkflowSnapshot (StreamName "wf:snap-w1") + case mSeed of + Just (m, v) -> do + v `shouldBe` StreamVersion 6 + Map.keys m `shouldBe` ["s1", "s2", "s3", "s4", "s5", "s6"] + Nothing -> expectationFailure "expected a workflow snapshot row" + + -- The OnTerminal completion-site wiring: only the final WorkflowCompleted + -- append (version 7) triggers the snapshot. + it "writes a terminal snapshot under OnTerminal at the completion version" $ \storeHandle -> do + counter <- newIORef (0 :: Int) + let name = WorkflowName "term" + wid = WorkflowId "tm1" + result <- + Store.runStoreIO storeHandle $ + runWorkflowWith + (defaultWorkflowRunOptions & #snapshotPolicy .~ OnTerminal) + name + wid + (countingSixSteps counter) + result `shouldBe` Right (Completed [1, 2, 3, 4, 5, 6]) + Right snapVersion <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + Tx.statement "wf:term-tm1" snapshotVersionForStreamStmt + snapVersion `shouldBe` Just (StreamVersion 7) + + -- Validation (b): re-hydration reads only the tail after the snapshot + -- version, and the journaled steps short-circuit (the counter stays put). + it "reads only the tail after the snapshot version on re-hydration" $ \storeHandle -> do + counter <- newIORef (0 :: Int) + let name = WorkflowName "tail" + wid = WorkflowId "t1" + opts = defaultWorkflowRunOptions & #snapshotPolicy .~ Every 2 + first <- Store.runStoreIO storeHandle $ runWorkflowWith opts name wid (countingSixSteps counter) + first `shouldBe` Right (Completed [1, 2, 3, 4, 5, 6]) + afterFirst <- readIORef counter + afterFirst `shouldBe` 6 + -- A full version-0 replay would read every journal event... + Right full <- + Store.runStoreIO storeHandle $ + Store.readStreamForward (StreamName "wf:tail-t1") (StreamVersion 0) 100 + Vector.length full `shouldBe` 7 -- six StepRecorded + one WorkflowCompleted + -- ...whereas the runtime seeds from the snapshot and reads only the tail. + Right (Just (seedMap, StreamVersion sv)) <- + Store.runStoreIO storeHandle $ loadWorkflowSnapshot (StreamName "wf:tail-t1") + Map.size seedMap `shouldBe` 6 + Right tailEvents <- + Store.runStoreIO storeHandle $ + Store.readStreamForward (StreamName "wf:tail-t1") (StreamVersion sv) 100 + Vector.length tailEvents `shouldSatisfy` (< Vector.length full) + Vector.length tailEvents `shouldBe` 1 -- only the WorkflowCompleted at v7 + -- Re-hydration completes from the seed without re-running any step. + second <- Store.runStoreIO storeHandle $ runWorkflowWith opts name wid (countingSixSteps counter) + second `shouldBe` Right (Completed [1, 2, 3, 4, 5, 6]) + afterSecond <- readIORef counter + afterSecond `shouldBe` 6 + + -- Validation (c): a Never run and an Every 2 run produce identical results + -- and identical journals, and the snapshot seed equals a full replay. + it "produces identical results and journals under Never and Every 2" $ \storeHandle -> do + counterN <- newIORef (0 :: Int) + counterE <- newIORef (0 :: Int) + neverRes <- + Store.runStoreIO storeHandle $ + runWorkflowWith + (defaultWorkflowRunOptions & #snapshotPolicy .~ Never) + (WorkflowName "corr-never") + (WorkflowId "c1") + (countingSixSteps counterN) + everyRes <- + Store.runStoreIO storeHandle $ + runWorkflowWith + (defaultWorkflowRunOptions & #snapshotPolicy .~ Every 2) + (WorkflowName "corr-every") + (WorkflowId "c1") + (countingSixSteps counterE) + neverRes `shouldBe` Right (Completed [1, 2, 3, 4, 5, 6]) + everyRes `shouldBe` Right (Completed [1, 2, 3, 4, 5, 6]) + Right neverEvents <- + Store.runStoreIO storeHandle $ + Store.readStreamForward (StreamName "wf:corr-never-c1") (StreamVersion 0) 100 + Right everyEvents <- + Store.runStoreIO storeHandle $ + Store.readStreamForward (StreamName "wf:corr-every-c1") (StreamVersion 0) 100 + let stepResults evs = + [ (k, v) + | Right (StepRecorded k v _) <- decodeRecorded workflowJournalCodec <$> Vector.toList evs + ] + stepResults neverEvents `shouldBe` stepResults everyEvents + -- The snapshot seed equals the map a full version-0 replay would fold. + Right (Just (seedMap, _)) <- + Store.runStoreIO storeHandle $ loadWorkflowSnapshot (StreamName "wf:corr-every-c1") + seedMap `shouldBe` Map.fromList (stepResults everyEvents) + + -- Validation (d): an advisory snapshot whose discriminant no longer matches + -- is ignored and the workflow hydrates via full replay. + it "hydrates via full replay when the snapshot discriminant mismatches" $ \storeHandle -> do + counter <- newIORef (0 :: Int) + let name = WorkflowName "dmiss" + wid = WorkflowId "d1" + opts = defaultWorkflowRunOptions & #snapshotPolicy .~ Every 2 + _ <- Store.runStoreIO storeHandle $ runWorkflowWith opts name wid (countingSixSteps counter) + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + Tx.statement ("wf:dmiss-d1", "stale-shape") corruptSnapshotShapeStmt + Right mSeed <- Store.runStoreIO storeHandle $ loadWorkflowSnapshot (StreamName "wf:dmiss-d1") + mSeed `shouldBe` Nothing + resumed <- Store.runStoreIO storeHandle $ runWorkflowWith opts name wid (countingSixSteps counter) + resumed `shouldBe` Right (Completed [1, 2, 3, 4, 5, 6]) + + -- Validation (d), second arm: corrupt snapshot JSON is treated as a miss. + it "hydrates via full replay when the snapshot JSON is corrupt" $ \storeHandle -> do + (exporter, metricsRef) <- inMemoryMetricExporter + (provider, _env) <- + createMeterProvider + emptyMaterializedResources + defaultSdkMeterProviderOptions {metricExporter = Just exporter} + meter <- getMeter provider Telemetry.keiroInstrumentationLibrary + keiroMetrics <- Telemetry.newKeiroMetrics meter + counter <- newIORef (0 :: Int) + let name = WorkflowName "cjson" + wid = WorkflowId "d2" + opts = + defaultWorkflowRunOptions + & #snapshotPolicy + .~ Every 2 + & #metrics + ?~ keiroMetrics + _ <- Store.runStoreIO storeHandle $ runWorkflowWith opts name wid (countingSixSteps counter) + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + Tx.statement ("wf:cjson-d2", Aeson.String "bad") corruptSnapshotStateStmt + Right mSeed <- Store.runStoreIO storeHandle $ loadWorkflowSnapshot (StreamName "wf:cjson-d2") + mSeed `shouldBe` Nothing + resumed <- Store.runStoreIO storeHandle $ runWorkflowWith opts name wid (countingSixSteps counter) + resumed `shouldBe` Right (Completed [1, 2, 3, 4, 5, 6]) + _ <- forceFlushMeterProvider provider Nothing + exported <- readIORef metricsRef + let scalars = flattenScalarPoints exported + lookup "keiro.snapshot.decode.failures" scalars `shouldBe` Just (IntNumber 1) + lookup "keiro.snapshot.read.misses" scalars `shouldBe` Just (IntNumber 2) + + describe "Keiro.Workflow snapshot wake-safety" $ around (withFreshStore fixture) $ do + it "keeps a genuinely unresolved awakeable pending under Every 1" $ \storeHandle -> do + aidRef <- newIORef Nothing + let name = WorkflowName "snapshot-unsignalled" + wid = WorkflowId "wf1" + opts = defaultWorkflowRunOptions & #snapshotPolicy .~ Every 1 + run = Store.runStoreIO storeHandle $ runWorkflowWith opts name wid (snapshotUnsignalledAwakeable aidRef) + first <- run + first `shouldBe` Right Suspended + aid <- readRequiredAwakeableId aidRef + Right (Just rowAfterFirst) <- Store.runStoreIO storeHandle $ Awk.lookupAwakeable (awakeableIdToUuid aid) + rowAfterFirst ^. #status `shouldBe` Awk.Pending + rowAfterFirst ^. #payload `shouldBe` Nothing + second <- run + second `shouldBe` Right Suspended + Right (Just rowAfterSecond) <- Store.runStoreIO storeHandle $ Awk.lookupAwakeable (awakeableIdToUuid aid) + rowAfterSecond ^. #status `shouldBe` Awk.Pending + rowAfterSecond ^. #payload `shouldBe` Nothing + + it "delivers an awakeable signalled mid-run despite the stale in-memory map" $ \storeHandle -> do + aidRef <- newIORef Nothing + let name = WorkflowName "snapshot-midrun-awakeable" + wid = WorkflowId "wf1" + opts = defaultWorkflowRunOptions & #snapshotPolicy .~ Every 1 + run = Store.runStoreIO storeHandle $ runWorkflowWith opts name wid snapshotShadowedAwakeable + armed <- + Store.runStoreIO storeHandle $ + runWorkflowWith opts name wid (snapshotUnsignalledAwakeable aidRef) + armed `shouldBe` Right Suspended + first <- run + first `shouldBe` Right (Completed "payload") + second <- run + second `shouldBe` Right (Completed "payload") + + it "delivers an awakeable shadowed by a snapshot on a later run" $ \storeHandle -> do + aidRef <- newIORef Nothing + let name = WorkflowName "snapshot-stale-awakeable" + wid = WorkflowId "wf1" + opts = defaultWorkflowRunOptions & #snapshotPolicy .~ Every 1 + armed <- + Store.runStoreIO storeHandle $ + runWorkflowWith opts name wid (snapshotUnsignalledAwakeable aidRef) + armed `shouldBe` Right Suspended + first <- + Store.runStoreIO storeHandle $ + runWorkflowWith opts name wid (snapshotStaleAwakeablePhaseOne aidRef) + first `shouldBe` Right Suspended + aid <- readRequiredAwakeableId aidRef + Right (Just (staleSeed, _)) <- + Store.runStoreIO storeHandle $ + loadWorkflowSnapshot (workflowGenerationStreamName name wid 0) + staleSeed `shouldSatisfy` Map.notMember ("awk:" <> awakeableIdText aid) + second <- + Store.runStoreIO storeHandle $ + runWorkflowWith opts name wid snapshotStaleAwakeablePhaseTwo + second `shouldBe` Right (Completed "payload") + + it "delivers a child completion shadowed by a snapshot on a later run" $ \storeHandle -> do + let name = WorkflowName "snapshot-stale-child-parent" + wid = WorkflowId "wf1" + childWid = WorkflowId "child1" + opts = defaultWorkflowRunOptions & #snapshotPolicy .~ Every 1 + first <- + Store.runStoreIO storeHandle $ + runWorkflowWith opts name wid (snapshotStaleChildPhaseOne childWid) + first `shouldBe` Right Suspended + Right (Just (staleSeed, _)) <- + Store.runStoreIO storeHandle $ + loadWorkflowSnapshot (workflowGenerationStreamName name wid 0) + staleSeed `shouldSatisfy` Map.notMember (childResultStepName childWid) + second <- + Store.runStoreIO storeHandle $ + runWorkflowWith opts name wid (snapshotStaleChildPhaseTwo childWid) + second `shouldBe` Right (Completed "packed+labelled") + + describe "Keiro.Workflow.Resume" $ around (withFreshStore fixture) $ do + -- M2: crash mid-run, then a resume pass drives the workflow to Completed + -- without re-running the already-journaled step. + it "resumes a crashed mid-run workflow, running only the un-journaled tail" $ \storeHandle -> do + counter <- newIORef (0 :: Int) + let name = WorkflowName "crash-demo" + wid = WorkflowId "cd-1" + -- Simulate a crash after step 1's append has committed. + crashed <- + try + ( Store.runStoreIO storeHandle $ + runWorkflow name wid (crashAfterStep1 counter) + ) :: + IO (Either SomeException (Either Store.StoreError (WorkflowOutcome (Int, Int, Int)))) + case crashed of + Left _ -> pure () -- the SimulatedCrash unwound the run, as intended + Right other -> expectationFailure ("expected a simulated crash, got " <> show other) + readIORef counter >>= \c -> c `shouldBe` 1 + -- Resume with a registry mapping the name to the FULL definition. + let registry = Map.singleton name (WorkflowDef (\_wid -> threeStep counter)) + Right summary <- + Store.runStoreIO storeHandle $ resumeWorkflowsOnce defaultWorkflowResumeOptions registry + summary + `shouldBe` ResumeSummary + { discovered = 1, + resumed = 1, + completed = 1, + stillSuspended = 0, + unknownName = 0, + failed = 0, + transientErrors = 0, + leaseSkipped = 0 + } + -- Step 1 short-circuited; steps 2 and 3 ran exactly once. + readIORef counter >>= \c -> c `shouldBe` 3 + -- The journal now holds s1, s2, s3, WorkflowCompleted. + Right recorded <- + Store.runStoreIO storeHandle $ + Store.readStreamForward (StreamName "wf:crash-demo-cd-1") (StreamVersion 0) 10 + traverse (decodeRecorded workflowJournalCodec) (Vector.toList recorded) + `shouldSatisfy` \case + Right [StepRecorded "s1" _ _, StepRecorded "s2" _ _, StepRecorded "s3" _ _, WorkflowCompleted _] -> True + _ -> False + -- A second pass discovers nothing — the workflow is finished. + Right summary2 <- + Store.runStoreIO storeHandle $ resumeWorkflowsOnce defaultWorkflowResumeOptions registry + summary2 `shouldBe` emptyResumeSummary + + -- M3: a workflow suspended on an awaited step is driven to Completed once + -- that step is journaled (here simulated; an EP-39/EP-40 wake source would + -- journal the same StepRecorded end to end). + it "resumes a suspended workflow once its awaited step is journaled" $ \storeHandle -> do + counter <- newIORef (0 :: Int) + let name = WorkflowName "await-demo" + wid = WorkflowId "ad-1" + suspended <- + Store.runStoreIO storeHandle $ runWorkflow name wid (awaitingThenStep counter) + suspended `shouldBe` Right Suspended + -- Simulate the wake source resolving the await. + Right () <- Store.runStoreIO storeHandle $ do + now <- liftIO getCurrentTime + appendJournalEntry name wid (StepRecorded "awk:approval" (toJSON ("ok" :: Text)) now) + let registry = Map.singleton name (WorkflowDef (\_wid -> awaitingThenStep counter)) + Right summary <- + Store.runStoreIO storeHandle $ resumeWorkflowsOnce defaultWorkflowResumeOptions registry + summary + `shouldBe` ResumeSummary + { discovered = 1, + resumed = 1, + completed = 1, + stillSuspended = 0, + unknownName = 0, + failed = 0, + transientErrors = 0, + leaseSkipped = 0 + } + readIORef counter >>= \c -> c `shouldBe` 1 + Right recorded <- + Store.runStoreIO storeHandle $ + Store.readStreamForward (StreamName "wf:await-demo-ad-1") (StreamVersion 0) 10 + traverse (decodeRecorded workflowJournalCodec) (Vector.toList recorded) + `shouldSatisfy` \case + Right [StepRecorded "awk:approval" _ _, StepRecorded "use" _ _, WorkflowCompleted _] -> True + _ -> False + + -- M4: a discovered workflow whose name is absent from the registry is + -- skipped and counted, never silently dropped or fatal. + it "skips and counts a workflow whose name is absent from the registry" $ \storeHandle -> do + counter <- newIORef (0 :: Int) + let name = WorkflowName "orphan" + wid = WorkflowId "or-1" + crashed <- + try + ( Store.runStoreIO storeHandle $ + runWorkflow name wid (crashAfterStep1 counter) + ) :: + IO (Either SomeException (Either Store.StoreError (WorkflowOutcome (Int, Int, Int)))) + case crashed of + Left _ -> pure () + Right other -> expectationFailure ("expected a simulated crash, got " <> show other) + -- Empty registry: the orphan is surfaced via unknownName, not completed. + Right summary <- + Store.runStoreIO storeHandle $ resumeWorkflowsOnce defaultWorkflowResumeOptions Map.empty + summary + `shouldBe` ResumeSummary + { discovered = 1, + resumed = 0, + completed = 0, + stillSuspended = 0, + unknownName = 1, + failed = 0, + transientErrors = 0, + leaseSkipped = 0 + } + -- The journal is unchanged: still one step, no completion. + Right recorded <- + Store.runStoreIO storeHandle $ + Store.readStreamForward (StreamName "wf:orphan-or-1") (StreamVersion 0) 10 + Vector.length recorded `shouldBe` 1 + + it "isolates a poison workflow so a healthy workflow still completes" $ \storeHandle -> do + healthyCounter <- newIORef (0 :: Int) + let poisonName = WorkflowName "poison" + poisonId = WorkflowId "poison-1" + healthyName = WorkflowName "healthy" + healthyId = WorkflowId "healthy-1" + opts = + defaultWorkflowResumeOptions + & #maxAttempts + .~ 1 + & #logEvent + .~ const (pure ()) + registry = + Map.fromList + [ (poisonName, WorkflowDef (\_ -> liftIO (throwIO SimulatedCrash) *> pure (0 :: Int))), + (healthyName, WorkflowDef (\_ -> threeStep healthyCounter)) + ] + now <- getCurrentTime + Right () <- + Store.runStoreIO storeHandle $ + appendJournalEntry poisonName poisonId (StepRecorded "seed" (toJSON True) now) + crashed <- + try + ( Store.runStoreIO storeHandle $ + runWorkflow healthyName healthyId (crashAfterStep1 healthyCounter) + ) :: + IO (Either SomeException (Either Store.StoreError (WorkflowOutcome (Int, Int, Int)))) + case crashed of + Left _ -> pure () + Right other -> expectationFailure ("expected a simulated crash, got " <> show other) + Right summary <- Store.runStoreIO storeHandle $ resumeWorkflowsOnce opts registry + summary + `shouldBe` emptyResumeSummary + { discovered = 2, + resumed = 2, + completed = 1, + failed = 1 + } + readIORef healthyCounter >>= \c -> c `shouldBe` 3 + Right (Just poisonRow) <- Store.runStoreIO storeHandle $ Instance.lookupInstance poisonName poisonId + poisonRow ^. #status `shouldBe` Instance.WfFailed + + it "marks a crashing workflow failed and short-circuits later direct runs" $ \storeHandle -> do + let name = WorkflowName "terminal-poison" + wid = WorkflowId "tp-1" + opts = + defaultWorkflowResumeOptions + & #maxAttempts + .~ 1 + & #logEvent + .~ const (pure ()) + registry = Map.singleton name (WorkflowDef (\_ -> liftIO (throwIO SimulatedCrash) *> pure (0 :: Int))) + now <- getCurrentTime + Right () <- + Store.runStoreIO storeHandle $ + appendJournalEntry name wid (StepRecorded "seed" (toJSON True) now) + Right summary <- Store.runStoreIO storeHandle $ resumeWorkflowsOnce opts registry + failed summary `shouldBe` 1 + Right (Just row) <- Store.runStoreIO storeHandle $ Instance.lookupInstance name wid + row ^. #status `shouldBe` Instance.WfFailed + row ^. #attempts `shouldBe` 1 + direct <- Store.runStoreIO storeHandle $ runWorkflow name wid (step (StepName "never") (pure (1 :: Int))) + direct `shouldBe` Right Failed + Right recordedFailed <- + Store.runStoreIO storeHandle $ + Store.readStreamForward (StreamName "wf:terminal-poison-tp-1") (StreamVersion 0) 10 + traverse (decodeRecorded workflowJournalCodec) (Vector.toList recordedFailed) + `shouldSatisfy` \case + Right events -> any (\case WorkflowFailed {} -> True; _ -> False) events + _ -> False + + it "resurrects a failed workflow and completes without rerunning its journaled prefix" $ \storeHandle -> do + shouldCrash <- newIORef True + counter <- newIORef (0 :: Int) + let name = WorkflowName "resurrect-complete" + wid = WorkflowId "rc-1" + opts = + defaultWorkflowResumeOptions + & #maxAttempts + .~ 1 + & #logEvent + .~ const (pure ()) + registry = Map.singleton name (WorkflowDef (\_ -> recoverableWorkflow shouldCrash counter)) + crashed <- + try + ( Store.runStoreIO storeHandle $ + runWorkflow name wid (recoverableWorkflow shouldCrash counter) + ) :: + IO (Either SomeException (Either Store.StoreError (WorkflowOutcome Int))) + case crashed of + Left _ -> pure () + Right other -> expectationFailure ("expected a simulated crash, got " <> show other) + readIORef counter `shouldReturn` 1 + + Right failedPass <- Store.runStoreIO storeHandle $ resumeWorkflowsOnce opts registry + failed failedPass `shouldBe` 1 + Right (Just failedRow) <- Store.runStoreIO storeHandle $ Instance.lookupInstance name wid + failedRow ^. #status `shouldBe` Instance.WfFailed + + writeIORef shouldCrash False + resurrected <- Store.runStoreIO storeHandle $ Instance.resurrectFailedWorkflow name wid + resurrected `shouldBe` Right Instance.WorkflowResurrected + Right (Just revivedRow) <- Store.runStoreIO storeHandle $ Instance.lookupInstance name wid + revivedRow ^. #status `shouldBe` Instance.WfRunning + revivedRow ^. #attempts `shouldBe` 0 + revivedRow ^. #lastError `shouldBe` Nothing + revivedRow ^. #nextAttemptAt `shouldBe` Nothing + + Right completedPass <- Store.runStoreIO storeHandle $ resumeWorkflowsOnce opts registry + completed completedPass `shouldBe` 1 + readIORef counter `shouldReturn` 2 + Right (Just completedRow) <- Store.runStoreIO storeHandle $ Instance.lookupInstance name wid + completedRow ^. #status `shouldBe` Instance.WfCompleted + + it "can fail again in the same generation after resurrection" $ \storeHandle -> do + shouldCrash <- newIORef True + counter <- newIORef (0 :: Int) + let name = WorkflowName "resurrect-refail" + wid = WorkflowId "rr-1" + opts = + defaultWorkflowResumeOptions + & #maxAttempts + .~ 1 + & #logEvent + .~ const (pure ()) + registry = Map.singleton name (WorkflowDef (\_ -> recoverableWorkflow shouldCrash counter)) + crashed <- + try + ( Store.runStoreIO storeHandle $ + runWorkflow name wid (recoverableWorkflow shouldCrash counter) + ) :: + IO (Either SomeException (Either Store.StoreError (WorkflowOutcome Int))) + case crashed of + Left _ -> pure () + Right other -> expectationFailure ("expected a simulated crash, got " <> show other) + + Right firstFailedPass <- Store.runStoreIO storeHandle $ resumeWorkflowsOnce opts registry + failed firstFailedPass `shouldBe` 1 + firstRevival <- Store.runStoreIO storeHandle $ Instance.resurrectFailedWorkflow name wid + firstRevival `shouldBe` Right Instance.WorkflowResurrected + Right secondFailedPass <- Store.runStoreIO storeHandle $ resumeWorkflowsOnce opts registry + failed secondFailedPass `shouldBe` 1 + Right (Just refailedRow) <- Store.runStoreIO storeHandle $ Instance.lookupInstance name wid + refailedRow ^. #status `shouldBe` Instance.WfFailed + + Right recorded <- + Store.runStoreIO storeHandle $ + Store.readStreamForward + (workflowGenerationStreamName name wid 0) + (StreamVersion 0) + 10 + let failureIds = + [ event ^. #eventId + | event <- Vector.toList recorded, + Right decoded <- [decodeRecorded workflowJournalCodec event], + WorkflowFailed {} <- [decoded] + ] + case failureIds of + [firstFailureId, secondFailureId] -> + firstFailureId `shouldNotBe` secondFailureId + other -> + expectationFailure ("expected two failure events, got " <> show other) + + secondRevival <- Store.runStoreIO storeHandle $ Instance.resurrectFailedWorkflow name wid + secondRevival `shouldBe` Right Instance.WorkflowResurrected + + it "guards resurrection and revives a failed child link transactionally" $ \storeHandle -> do + let runningName = WorkflowName "resurrect-running" + runningId = WorkflowId "running-1" + missingName = WorkflowName "resurrect-missing" + missingId = WorkflowId "missing-1" + childName = WorkflowName "resurrect-child" + childId = WorkflowId "child-1" + now <- getCurrentTime + Right () <- + Store.runStoreIO storeHandle $ + appendJournalEntry runningName runningId (StepRecorded "seed" (toJSON True) now) + runningOutcome <- Store.runStoreIO storeHandle $ Instance.resurrectFailedWorkflow runningName runningId + runningOutcome `shouldBe` Right Instance.WorkflowNotFailed + missingOutcome <- Store.runStoreIO storeHandle $ Instance.resurrectFailedWorkflow missingName missingId + missingOutcome `shouldBe` Right Instance.WorkflowNotFound + + Right childMarkedFailed <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ do + Child.registerChildTx + "child-1" + "resurrect-child" + "parent-1" + "resurrect-parent" + "child:child-1:result" + Child.markChildFailedTx "child-1" "resurrect-child" "simulated terminal failure" + childMarkedFailed `shouldBe` True + Right () <- + Store.runStoreIO storeHandle $ + appendJournalEntry childName childId (WorkflowFailed "simulated terminal failure" now) + + childOutcome <- Store.runStoreIO storeHandle $ Instance.resurrectFailedWorkflow childName childId + childOutcome `shouldBe` Right Instance.WorkflowResurrected + Right (Just childRow) <- Store.runStoreIO storeHandle $ Child.lookupChild "child-1" "resurrect-child" + childRow ^. #status `shouldBe` Child.Running + childRow ^. #result `shouldBe` Nothing + childRow ^. #failureReason `shouldBe` Nothing + childRow ^. #completedAt `shouldBe` Nothing + + it "classifies thrown store errors as transient without consuming attempts" $ \storeHandle -> do + let name = WorkflowName "transient" + wid = WorkflowId "tr-1" + opts = defaultWorkflowResumeOptions & #logEvent .~ const (pure ()) + registry = + Map.singleton name $ + WorkflowDef + ( \_ -> do + _ <- throwError (Store.ConnectionLost "boom") + pure (0 :: Int) + ) + now <- getCurrentTime + Right () <- + Store.runStoreIO storeHandle $ + appendJournalEntry name wid (StepRecorded "seed" (toJSON True) now) + Right summary <- Store.runStoreIO storeHandle $ resumeWorkflowsOnce opts registry + transientErrors summary `shouldBe` 1 + failed summary `shouldBe` 0 + Right (Just row) <- Store.runStoreIO storeHandle $ Instance.lookupInstance name wid + row ^. #attempts `shouldBe` 0 + row ^. #status `shouldBe` Instance.WfRunning + + it "keeps the fixed-poll loop alive when one pass contains a poison workflow" $ \storeHandle -> do + done <- newEmptyMVar + healthyCounter <- newIORef (0 :: Int) + let poisonName = WorkflowName "fixed-loop-poison" + poisonId = WorkflowId "flp-1" + healthyName = WorkflowName "fixed-loop-healthy" + healthyId = WorkflowId "flh-1" + opts = + defaultWorkflowResumeOptions + & #pollInterval + .~ 50_000 + & #maxAttempts + .~ 1 + & #logEvent + .~ const (pure ()) + healthyBody = threeStepThenSignal healthyCounter done + registry = + Map.fromList + [ (poisonName, WorkflowDef (\_ -> liftIO (throwIO SimulatedCrash) *> pure (0 :: Int))), + (healthyName, WorkflowDef (\_ -> healthyBody)) + ] + now <- getCurrentTime + Right () <- + Store.runStoreIO storeHandle $ + appendJournalEntry poisonName poisonId (StepRecorded "seed" (toJSON True) now) + crashed <- + try + ( Store.runStoreIO storeHandle $ + runWorkflow healthyName healthyId (crashAfterStep1 healthyCounter) + ) :: + IO (Either SomeException (Either Store.StoreError (WorkflowOutcome (Int, Int, Int)))) + case crashed of + Left _ -> pure () + Right other -> expectationFailure ("expected a simulated crash, got " <> show other) + worker <- forkIO (void (Store.runStoreIO storeHandle (runWorkflowResumeWorkerWith opts registry))) + completed <- timeout 5_000_000 (takeMVar done) + status <- threadStatus worker + killThread worker + completed `shouldBe` Just () + status `shouldSatisfy` \case + ThreadFinished -> False + ThreadDied -> False + _ -> True + + it "claims one workflow instance for a single live owner and releases it" $ \storeHandle -> do + let name = WorkflowName "lease-claim" + wid = WorkflowId "lc-1" + Right claimedA <- Store.runStoreIO storeHandle $ Instance.claimInstance "owner-a" 30 name wid + claimedA `shouldBe` True + Right claimedB <- Store.runStoreIO storeHandle $ Instance.claimInstance "owner-b" 30 name wid + claimedB `shouldBe` False + Right () <- Store.runStoreIO storeHandle $ Instance.releaseInstance "owner-a" False name wid + Right claimedBAfterRelease <- Store.runStoreIO storeHandle $ Instance.claimInstance "owner-b" 30 name wid + claimedBAfterRelease `shouldBe` True + + it "lets an expired workflow lease be taken and resets attempts on progressed release" $ \storeHandle -> do + let name = WorkflowName "lease-expire" + wid = WorkflowId "le-1" + Right claimedA <- Store.runStoreIO storeHandle $ Instance.claimInstance "owner-a" 30 name wid + claimedA `shouldBe` True + Right attempt <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + Instance.recordCrashTx "le-1" "lease-expire" "boom" + attempt `shouldBe` 1 + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + Tx.sql "UPDATE keiro.keiro_workflows SET lease_expires_at = now() - interval '1 second', next_attempt_at = now() - interval '1 second' WHERE workflow_id = 'le-1' AND workflow_name = 'lease-expire'" + Right claimedB <- Store.runStoreIO storeHandle $ Instance.claimInstance "owner-b" 30 name wid + claimedB `shouldBe` True + Right () <- Store.runStoreIO storeHandle $ Instance.releaseInstance "owner-b" True name wid + Right (Just row) <- Store.runStoreIO storeHandle $ Instance.lookupInstance name wid + row ^. #attempts `shouldBe` 0 + row ^. #lastError `shouldBe` Nothing + row ^. #nextAttemptAt `shouldBe` Nothing + row ^. #leasedBy `shouldBe` Nothing + + it "skips a resume candidate held by another live lease owner" $ \storeHandle -> do + ran <- newIORef False + let name = WorkflowName "lease-skip" + wid = WorkflowId "ls-1" + registry = + Map.singleton name $ + WorkflowDef + ( \_ -> do + liftIO (writeIORef ran True) + pure (0 :: Int) + ) + now <- getCurrentTime + Right () <- + Store.runStoreIO storeHandle $ + appendJournalEntry name wid (StepRecorded "seed" (toJSON True) now) + Right foreignClaim <- Store.runStoreIO storeHandle $ Instance.claimInstance "foreign-owner" 30 name wid + foreignClaim `shouldBe` True + Right summary <- Store.runStoreIO storeHandle $ resumeWorkflowsOnce defaultWorkflowResumeOptions registry + summary + `shouldBe` emptyResumeSummary + { discovered = 1, + leaseSkipped = 1 + } + readIORef ran `shouldReturn` False + + -- M4: resume on an already-completed workflow is a genuine no-op. + it "discovers nothing for an already-completed workflow and is stable" $ \storeHandle -> do + counter <- newIORef (0 :: Int) + let name = WorkflowName "done-demo" + wid = WorkflowId "dd-1" + done <- Store.runStoreIO storeHandle $ runWorkflow name wid (threeStep counter) + done `shouldBe` Right (Completed (1, 2, 3)) + readIORef counter >>= \c -> c `shouldBe` 3 + let registry = Map.singleton name (WorkflowDef (\_wid -> threeStep counter)) + Right summary1 <- + Store.runStoreIO storeHandle $ resumeWorkflowsOnce defaultWorkflowResumeOptions registry + summary1 `shouldBe` emptyResumeSummary + Right summary2 <- + Store.runStoreIO storeHandle $ resumeWorkflowsOnce defaultWorkflowResumeOptions registry + summary2 `shouldBe` emptyResumeSummary + readIORef counter >>= \c -> c `shouldBe` 3 + + describe "Keiro.Workflow lease renewal" $ around (withFreshStore fixture) $ do + it "renews before a slow fresh step so the original lease cannot be stolen" $ \storeHandle -> do + attemptedClaim <- newIORef Nothing + let name = WorkflowName "lease-heartbeat" + wid = WorkflowId "heartbeat-1" + runOpts = + defaultWorkflowRunOptions + & #leaseHeartbeat + .~ Just LeaseHeartbeat {owner = "owner-a", ttl = 60} + body = + step (StepName "slow-boundary") $ do + liftIO (threadDelay 300_000) + claimed <- + Instance.claimInstance + "owner-b" + 60 + name + wid + liftIO (writeIORef attemptedClaim (Just claimed)) + pure claimed + Right claimedA <- Store.runStoreIO storeHandle $ Instance.claimInstance "owner-a" 0.2 name wid + claimedA `shouldBe` True + outcome <- Store.runStoreIO storeHandle $ runWorkflowWith runOpts name wid body + outcome `shouldBe` Right (Completed False) + readIORef attemptedClaim `shouldReturn` Just False + Right (Just row) <- Store.runStoreIO storeHandle $ Instance.lookupInstance name wid + row ^. #leasedBy `shouldBe` Just "owner-a" + + it "stops at a lost lease boundary and the resume worker records no crash" $ \storeHandle -> do + let directName = WorkflowName "lease-lost-direct" + directId = WorkflowId "lost-direct-1" + directOpts = + defaultWorkflowRunOptions + & #leaseHeartbeat + .~ Just LeaseHeartbeat {owner = "owner-a", ttl = 60} + now <- getCurrentTime + Right () <- + Store.runStoreIO storeHandle $ + appendJournalEntry directName directId (StepRecorded "seed" (toJSON True) now) + Right claimedA <- Store.runStoreIO storeHandle $ Instance.claimInstance "owner-a" 60 directName directId + claimedA `shouldBe` True + leaseUntil <- addUTCTime 60 <$> getCurrentTime + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + Tx.statement + ("lost-direct-1", "lease-lost-direct", "owner-b", leaseUntil) + forceWorkflowLeaseStmt + firstDirectEffect <- newIORef (0 :: Int) + secondDirectEffect <- newIORef (0 :: Int) + direct <- + try + ( Store.runStoreIO storeHandle $ + runWorkflowWith directOpts directName directId $ do + _ <- step (StepName "first") (liftIO (incrementAndRead firstDirectEffect)) + step (StepName "second") (liftIO (incrementAndRead secondDirectEffect)) + ) :: + IO + ( Either + WorkflowLeaseLost + (Either Store.StoreError (WorkflowOutcome Int)) + ) + direct `shouldBe` Left WorkflowLeaseLost + readIORef firstDirectEffect `shouldReturn` 0 + readIORef secondDirectEffect `shouldReturn` 0 + directFinishedAt <- getCurrentTime + Right () <- + Store.runStoreIO storeHandle $ + appendJournalEntry directName directId (WorkflowCompleted directFinishedAt) + + firstWorkerEffect <- newIORef (0 :: Int) + secondWorkerEffect <- newIORef (0 :: Int) + let workerName = WorkflowName "lease-lost-worker" + workerId = WorkflowId "lost-worker-1" + workerOpts = + defaultWorkflowResumeOptions + & #logEvent + .~ const (pure ()) + registry = + Map.singleton workerName $ + WorkflowDef $ \_ -> do + _ <- + step (StepName "first") $ do + value <- liftIO (incrementAndRead firstWorkerEffect) + expires <- liftIO (addUTCTime 60 <$> getCurrentTime) + Store.runTransaction $ + Tx.statement + ("lost-worker-1", "lease-lost-worker", "owner-b", expires) + forceWorkflowLeaseStmt + pure value + step (StepName "second") (liftIO (incrementAndRead secondWorkerEffect)) + Right () <- + Store.runStoreIO storeHandle $ + appendJournalEntry workerName workerId (StepRecorded "seed" (toJSON True) now) + Right summary <- Store.runStoreIO storeHandle $ resumeWorkflowsOnce workerOpts registry + summary + `shouldBe` emptyResumeSummary + { discovered = 1, + leaseSkipped = 1 + } + readIORef firstWorkerEffect `shouldReturn` 1 + readIORef secondWorkerEffect `shouldReturn` 0 + Right (Just row) <- Store.runStoreIO storeHandle $ Instance.lookupInstance workerName workerId + row ^. #attempts `shouldBe` 0 + row ^. #leasedBy `shouldBe` Just "owner-b" + + describe "Keiro.Workflow continue-as-new" $ around (withFreshStore fixture) $ do + -- EP-48 headline proof (Checks 1 & 2): a 300-step rolling-total workflow that + -- rotates every 50 steps keeps each physical generation journal bounded by + -- K = rotateEvery + 2 (at most rotateEvery work steps + the one seed step that + -- opened the generation + the one terminal marker), yet returns the correct + -- final total. A single non-rotating run would put all 300 steps on one + -- journal and the per-generation `<= K` bound would fail. + it "rotates a long workflow, bounds each generation, and returns the correct total" $ \storeHandle -> do + counter <- newIORef (0 :: Int) + let name = WorkflowName "roller" + wid = WorkflowId "r-1" + rotateEvery = 50 :: Int + total = 300 :: Int + k = rotateEvery + 2 + body = rollingTotal counter rotateEvery total + -- Re-invoke runWorkflow until it Completes; each call resolves and + -- advances the current generation, exactly as the resume worker does. + drive :: Int -> IO Int + drive budget + | budget <= 0 = + expectationFailure "workflow did not complete within the rotation budget" >> pure (-1) + | otherwise = do + outcome <- Store.runStoreIO storeHandle (runWorkflow name wid body) + case outcome of + Right ContinuedAsNew -> drive (budget - 1) + Right (Completed t) -> pure t + other -> expectationFailure ("unexpected outcome: " <> show other) >> pure (-1) + -- The first invocation rotates (generation 0 did rotateEvery steps). + firstOutcome <- Store.runStoreIO storeHandle (runWorkflow name wid body) + firstOutcome `shouldBe` Right ContinuedAsNew + -- Drive the remaining generations to completion (bounded passes). + finalTotal <- drive (total `div` rotateEvery + 3) + -- Check 2: correct result, and each side effect ran exactly once. + finalTotal `shouldBe` total + readIORef counter >>= (`shouldBe` total) + -- The workflow rotated to its final generation (300/50 = 6 generations: 0..5). + Right gen <- Store.runStoreIO storeHandle (currentGeneration name wid) + gen `shouldBe` (total `div` rotateEvery - 1) + -- Check 1: every generation's physical journal is bounded by K, and the + -- total is split ACROSS generations (bounded per generation, not in + -- aggregate). Each generation holds exactly 1 seed + rotateEvery work + 1 + -- marker = K events, so the sum is total + 2 per generation. + lengths <- + traverse + ( \g -> do + let streamName = workflowGenerationStreamName name wid g + Right evs <- Store.runStoreIO storeHandle (Store.readStreamForward streamName (StreamVersion 0) 1000) + pure (Vector.length evs) + ) + [0 .. gen] + for_ lengths (`shouldSatisfy` (<= k)) + sum lengths `shouldBe` (total + 2 * (gen + 1)) + -- The first generation ends with a rotation marker; the last with a + -- completion marker. + Right gen0evs <- Store.runStoreIO storeHandle (Store.readStreamForward (workflowGenerationStreamName name wid 0) (StreamVersion 0) 1000) + (decodeRecorded workflowJournalCodec <$> Vector.toList gen0evs) + `shouldSatisfy` any + ( \case + Right (WorkflowContinuedAsNew 1 _) -> True + _ -> False + ) + Right lastEvs <- Store.runStoreIO storeHandle (Store.readStreamForward (workflowGenerationStreamName name wid gen) (StreamVersion 0) 1000) + (decodeRecorded workflowJournalCodec <$> Vector.toList lastEvs) + `shouldSatisfy` any + ( \case + Right (WorkflowCompleted _) -> True + _ -> False + ) + + -- EP-48 Check 3: discovery and resume follow the CURRENT generation. After a + -- rotation the rotated (newer) generation is unfinished and discoverable — + -- the older generation's WorkflowContinuedAsNew marker does NOT mask it — and + -- the resume worker drives the rotated generation forward to completion. + it "rediscovers and resumes a rotated workflow on its current generation" $ \storeHandle -> do + counter <- newIORef (0 :: Int) + let name = WorkflowName "roller2" + wid = WorkflowId "r-2" + rotateEvery = 50 :: Int + total = 150 :: Int + registry = Map.singleton name (WorkflowDef (\_ -> rollingTotal counter rotateEvery total)) + resumeUntilDone :: Int -> IO () + resumeUntilDone budget + | budget <= 0 = expectationFailure "resume did not complete the rotated workflow" + | otherwise = do + Right summary <- + Store.runStoreIO storeHandle (resumeWorkflowsOnce defaultWorkflowResumeOptions registry) + if completed summary == 1 then pure () else resumeUntilDone (budget - 1) + -- First run rotates onto generation 1. + firstOutcome <- Store.runStoreIO storeHandle (runWorkflow name wid (rollingTotal counter rotateEvery total)) + firstOutcome `shouldBe` Right ContinuedAsNew + -- The rotated current generation (1) is unfinished and discoverable. + now <- getCurrentTime + Right unfinished <- Store.runStoreIO storeHandle (findUnfinishedWorkflowIds now) + unfinished `shouldBe` [("r-2", "roller2")] + -- The resume worker drives the rotated generation(s) to completion. + resumeUntilDone (total `div` rotateEvery + 3) + readIORef counter >>= (`shouldBe` total) + -- Finished: discovery now reports nothing for it. + finalNow <- getCurrentTime + Right finalUnfinished <- Store.runStoreIO storeHandle (findUnfinishedWorkflowIds finalNow) + finalUnfinished `shouldBe` [] + + describe "Keiro.Workflow patch API" $ around (withFreshStore fixture) $ do + it "an in-flight instance observes the OLD branch; a fresh instance the NEW branch; the decision is journaled once and stable" $ \storeHandle -> do + counter <- newIORef (0 :: Int) + let name = WorkflowName "patchwf" + inflight = WorkflowId "inflight-1" + fresh = WorkflowId "fresh-1" + patchOptions = defaultWorkflowRunOptions & #activePatches .~ Set.singleton fraudPatchId + + -- 1. Run the in-flight instance to a suspension under the PRE-patch code. + pre <- Store.runStoreIO storeHandle $ runWorkflow name inflight (prePatchWorkflow counter) + pre `shouldBe` Right Suspended + + -- 2. Redeploy: re-run the SAME instance id under the POST-patch code. It + -- already journaled reserve-inventory, so it is in flight -> False. + r1 <- Store.runStoreIO storeHandle $ runWorkflowWith patchOptions name inflight (postPatchWorkflow counter) + r1 `shouldBe` Right (Completed "old-branch") + + -- 3. Replay the in-flight instance again: same OLD branch, every time. + r2 <- Store.runStoreIO storeHandle $ runWorkflowWith patchOptions name inflight (postPatchWorkflow counter) + r2 `shouldBe` Right (Completed "old-branch") + + -- 4. A fresh instance under the POST-patch code takes the NEW branch. + f1 <- Store.runStoreIO storeHandle $ runWorkflowWith patchOptions name fresh (postPatchWorkflow counter) + f1 `shouldBe` Right (Completed "new-branch") + -- and stays on the new branch on replay. + f2 <- Store.runStoreIO storeHandle $ runWorkflowWith patchOptions name fresh (postPatchWorkflow counter) + f2 `shouldBe` Right (Completed "new-branch") + + -- 5. The patch decision is journaled exactly once per instance, with the + -- expected Bool, on the patch: key. + Right inflightJournal <- + Store.runStoreIO storeHandle $ + Store.readStreamForward (StreamName "wf:patchwf-inflight-1") (StreamVersion 0) 20 + let inflightDecisions = + [ v + | Right ev <- map (decodeRecorded workflowJournalCodec) (Vector.toList inflightJournal), + StepRecorded k v _ <- [ev], + k == patchStepName fraudPatchId + ] + inflightDecisions `shouldBe` [toJSON False] + + Right freshJournal <- + Store.runStoreIO storeHandle $ + Store.readStreamForward (StreamName "wf:patchwf-fresh-1") (StreamVersion 0) 20 + let freshDecisions = + [ v + | Right ev <- map (decodeRecorded workflowJournalCodec) (Vector.toList freshJournal), + StepRecorded k v _ <- [ev], + k == patchStepName fraudPatchId + ] + freshDecisions `shouldBe` [toJSON True] + let freshPatchSets = + [ v + | Right ev <- map (decodeRecorded workflowJournalCodec) (Vector.toList freshJournal), + StepRecorded k v _ <- [ev], + k == patchSetStepName + ] + freshPatchSets `shouldBe` [toJSON [unPatchId fraudPatchId]] + + it "a fresh instance suspended before its patch call still takes the NEW branch" $ \storeHandle -> do + counter <- newIORef (0 :: Int) + let name = WorkflowName "patch-after-suspend" + wid = WorkflowId "pas-1" + patchOptions = defaultWorkflowRunOptions & #activePatches .~ Set.singleton fraudPatchId + Right Suspended <- + Store.runStoreIO storeHandle $ + runWorkflowWith patchOptions name wid (postPatchAfterSuspendWorkflow counter) + now <- getCurrentTime + Right () <- + Store.runStoreIO storeHandle $ + appendJournalEntry name wid (StepRecorded "awk:gate" Aeson.Null now) + resumed <- + Store.runStoreIO storeHandle $ + runWorkflowWith patchOptions name wid (postPatchAfterSuspendWorkflow counter) + resumed `shouldBe` Right (Completed "new-branch") + + it "an in-flight instance with only wake-source completions stays on the OLD branch" $ \storeHandle -> do + let name = WorkflowName "patch-wake-only" + wid = WorkflowId "pwo-1" + patchOptions = defaultWorkflowRunOptions & #activePatches .~ Set.singleton fraudPatchId + Right Suspended <- Store.runStoreIO storeHandle $ runWorkflow name wid prePatchWakeOnlyWorkflow + now <- getCurrentTime + Right () <- + Store.runStoreIO storeHandle $ + appendJournalEntry name wid (StepRecorded "awk:gate" Aeson.Null now) + resumed <- + Store.runStoreIO storeHandle $ + runWorkflowWith patchOptions name wid postPatchWakeOnlyWorkflow + resumed `shouldBe` Right (Completed "old-branch") + + it "records the active patch set again for a fresh rotated generation" $ \storeHandle -> do + let name = WorkflowName "patch-rotating" + wid = WorkflowId "pr-1" + patchOptions = defaultWorkflowRunOptions & #activePatches .~ Set.singleton fraudPatchId + first <- Store.runStoreIO storeHandle $ runWorkflowWith patchOptions name wid rotatingPatchWorkflow + first `shouldBe` Right ContinuedAsNew + second <- Store.runStoreIO storeHandle $ runWorkflowWith patchOptions name wid rotatingPatchWorkflow + second `shouldBe` Right (Completed "new-branch") + Right gen1Journal <- + Store.runStoreIO storeHandle $ + Store.readStreamForward (workflowGenerationStreamName name wid 1) (StreamVersion 0) 20 + let gen1PatchSets = + [ v + | Right ev <- map (decodeRecorded workflowJournalCodec) (Vector.toList gen1Journal), + StepRecorded k v _ <- [ev], + k == patchSetStepName + ] + gen1PatchSets `shouldBe` [toJSON [unPatchId fraudPatchId]] + + describe "Keiro.Workflow patch recording at rotation" $ around (withFreshStore fixture) $ do + it "keeps the active patch after a wake append lands before the first rotated run" $ \storeHandle -> do + let name = WorkflowName "patch-rotation-race" + wid = WorkflowId "prr-1" + patchOptions = + defaultWorkflowRunOptions + & #activePatches + .~ Set.singleton fraudPatchId + generationOneStream = workflowGenerationStreamName name wid 1 + + first <- + Store.runStoreIO storeHandle $ + runWorkflowWith patchOptions name wid rotatingPatchWorkflow + first `shouldBe` Right ContinuedAsNew + Right patchSetRecorded <- + Store.runStoreIO storeHandle $ + stepExists name wid 1 patchSetStepName + patchSetRecorded `shouldBe` True + + now <- getCurrentTime + Right () <- + Store.runStoreIO storeHandle $ + appendJournalEntry + name + wid + ( StepRecorded + "awk:11111111-1111-1111-1111-111111111111" + (toJSON True) + now + ) + + second <- + Store.runStoreIO storeHandle $ + runWorkflowWith patchOptions name wid rotatingPatchWorkflow + second `shouldBe` Right (Completed "new-branch") + replayed <- + Store.runStoreIO storeHandle $ + runWorkflowWith patchOptions name wid rotatingPatchWorkflow + replayed `shouldBe` Right (Completed "new-branch") + + Right generationOneJournal <- + Store.runStoreIO storeHandle $ + Store.readStreamForward generationOneStream (StreamVersion 0) 20 + let decoded = + map (decodeRecorded workflowJournalCodec) (Vector.toList generationOneJournal) + patchSets = + [ value + | Right (StepRecorded key value _) <- decoded, + key == patchSetStepName + ] + decisions = + [ value + | Right (StepRecorded key value _) <- decoded, + key == patchStepName fraudPatchId + ] + patchSets `shouldBe` [toJSON [unPatchId fraudPatchId]] + decisions `shouldBe` [toJSON True] + + describe "Keiro.Wake" $ around (withFreshStore fixture) $ do + -- EP-50: the wake primitive over kiroku's existing per-store notifier. + it "returns WokenByTimeout when idle (no append)" $ \store -> do + wake <- wakeSignalFromStore store + reason <- waitForWake wake 200000 -- 200 ms + reason `shouldBe` WokenByTimeout + + it "returns WokenByNotify promptly after a real append" $ \store -> do + wake <- wakeSignalFromStore store + -- A real append bumps the streams row and fires kiroku's NOTIFY on + -- kiroku.events; the store's notifier ticks the broadcast channel. + now <- getCurrentTime + Right () <- + Store.runStoreIO store $ + appendJournalEntry (WorkflowName "wakedemo") (WorkflowId "w1") (StepRecorded "s" (toJSON True) now) + reason <- waitForWake wake 5000000 -- generous 5 s ceiling; the round-trip is milliseconds + reason `shouldBe` WokenByNotify + + it "neverWake always returns WokenByTimeout" $ \_store -> do + reason <- waitForWake neverWake 100000 + reason `shouldBe` WokenByTimeout + + describe "Keiro.Workflow push latency (EP-50)" $ around (withFreshStore fixture) $ do + -- The user-visible win: a gated workflow resumes within sub-second of the + -- gate append, under a deliberately large (10 s) fallback — so a pass that + -- resumes it sub-second can only have been woken by the NOTIFY, not the poll. + it "resumes a gated workflow sub-second after the gate append (10s fallback)" $ \store -> do + done <- newEmptyMVar + let name = WorkflowName "pushwf" + wid = WorkflowId "p-1" + registry = Map.singleton name (WorkflowDef (\_ -> gateThenSignal done)) + opts = defaultWorkflowResumeOptions & #pollInterval .~ 10000000 -- 10 s fallback + first <- Store.runStoreIO store (runWorkflow name wid (gateThenSignal done)) + first `shouldBe` Right Suspended + worker <- forkIO (runWorkflowResumeWorkerPush store opts registry) + -- Let the worker start, duplicate the tick channel, and park in its wait + -- before we append, so the gate's NOTIFY cannot be missed. + threadDelay 250000 + now <- getCurrentTime + Right () <- + Store.runStoreIO store $ + appendJournalEntry name wid (StepRecorded "awk:gate" (toJSON ()) now) + resumed <- timeout 5000000 (takeMVar done) + t1 <- getCurrentTime + killThread worker + resumed `shouldBe` Just () + let latency = realToFrac (diffUTCTime t1 now) :: Double + latency `shouldSatisfy` (< 1.0) + + it "logs a failed push pass and keeps draining after the store recovers" $ \store -> do + done <- newEmptyMVar + logs <- newIORef [] + let name = WorkflowName "push-recover" + wid = WorkflowId "pr-1" + registry = Map.singleton name (WorkflowDef (\_ -> gateThenSignal done)) + opts = + defaultWorkflowResumeOptions + & #pollInterval + .~ 100_000 + & #logEvent + .~ \event -> modifyIORef' logs (<> [event]) + waitForPassFailure = timeout 5_000_000 $ do + let go = do + seen <- readIORef logs + if any isPassFailure seen + then pure () + else threadDelay 20_000 >> go + go + isPassFailure = \case + ResumePassFailed {} -> True + _ -> False + first <- Store.runStoreIO store (runWorkflow name wid (gateThenSignal done)) + first `shouldBe` Right Suspended + Right () <- + Store.runStoreIO store $ + Store.runTransaction $ + Tx.sql "ALTER TABLE keiro.keiro_workflow_steps RENAME TO keiro_workflow_steps_hidden" + worker <- forkIO (runWorkflowResumeWorkerPush store opts registry) + logged <- waitForPassFailure + logged `shouldBe` Just () + Right () <- + Store.runStoreIO store $ + Store.runTransaction $ + Tx.sql "ALTER TABLE keiro.keiro_workflow_steps_hidden RENAME TO keiro_workflow_steps" + now <- getCurrentTime + Right () <- + Store.runStoreIO store $ + appendJournalEntry name wid (StepRecorded "awk:gate" (toJSON ()) now) + resumed <- timeout 5_000_000 (takeMVar done) + status <- threadStatus worker + killThread worker + resumed `shouldBe` Just () + status `shouldSatisfy` \case + ThreadFinished -> False + ThreadDied -> False + _ -> True + + describe "Keiro.Workflow push fallback (EP-50)" $ around (withFreshStore fixture) $ do + -- Push is strictly an optimization: with the worker on 'neverWake' (every + -- NOTIFY dropped) and a small fallback, the gated workflow still drains on + -- the durable poll. + it "still drains on the fallback timeout when no notification is delivered" $ \store -> do + done <- newEmptyMVar + let name = WorkflowName "fallbackwf" + wid = WorkflowId "f-1" + registry = Map.singleton name (WorkflowDef (\_ -> gateThenSignal done)) + onePass = void (Store.runStoreIO store (resumeWorkflowsOnce defaultWorkflowResumeOptions registry)) + first <- Store.runStoreIO store (runWorkflow name wid (gateThenSignal done)) + first `shouldBe` Right Suspended + worker <- forkIO (runPollLoopWith neverWake 200000 onePass) -- 200 ms fallback, no notifications + now <- getCurrentTime + Right () <- + Store.runStoreIO store $ + appendJournalEntry name wid (StepRecorded "awk:gate" (toJSON ()) now) + resumed <- timeout 5000000 (takeMVar done) + killThread worker + resumed `shouldBe` Just () + + describe "Shard lease" $ around (withFreshStore fixture) $ do + -- EP-51 M2: claim / renew / release / expiry at the SQL layer, with explicit + -- `now` timestamps standing in for the passage of time (no workers yet). The + -- exclusion guarantee is the FOR UPDATE SKIP LOCKED claim; disjointness and + -- failover are both observable purely from the lease table. + let subName = SubscriptionName "orders-shard" + wA = WorkerId sampleUuid + wB = WorkerId sampleUuid2 + ttl = 30 :: NominalDiffTime + t0 = UTCTime (ModifiedJulianDay 60000) (secondsToDiffTime 0) + tExpired = addUTCTime 60 t0 -- past A's 30 s lease + shardOpts = defaultShardedWorkerOptions (Category (CategoryName "orders")) 4 + it "validates sharded worker options before startup" $ \_store -> do + shouldBeRight_ (mkShardedWorkerOptions shardOpts) + mkShardedWorkerOptions (shardOpts & #shardCount .~ 0) + `shouldBeLeft` InvalidShardCount 0 + mkShardedWorkerOptions (shardOpts & #leaseTtl .~ 0) + `shouldBeLeft` InvalidShardLeaseTtl 0 + mkShardedWorkerOptions (shardOpts & #renewInterval .~ 0) + `shouldBeLeft` InvalidShardRenewInterval 0 + mkShardedWorkerOptions (shardOpts & #leaseTtl .~ 10 & #renewInterval .~ 10) + `shouldBeLeft` InvalidShardLeaseRenewInterval 10 10 + mkShardedWorkerOptions (shardOpts & #batchSize .~ 0) + `shouldBeLeft` InvalidShardBatchSize 0 + mkShardedWorkerOptions (shardOpts & #bufferSize .~ 0) + `shouldBeLeft` InvalidShardBufferSize 0 + mkShardedWorkerOptions (shardOpts & #handlerRetryDelay .~ KirokuSub.RetryDelay (-1)) + `shouldBeLeft` InvalidShardHandlerRetryDelay (KirokuSub.RetryDelay (-1)) + mkShardedWorkerOptions (shardOpts & #retryPolicy .~ KirokuSub.RetryPolicy 0) + `shouldBeLeft` InvalidShardRetryMaxAttempts 0 + + it "ensureShardRows populates N rows once (idempotent on re-run)" $ \store -> do + Right () <- Store.runStoreIO store $ Store.runTransaction $ do + ensureShardRows subName 4 + ensureShardRows subName 4 + Right rows <- Store.runStoreIO store $ Store.runTransaction (listShardOwnership subName) + map (\(b, _, _) -> b) rows `shouldBe` [0, 1, 2, 3] + all (\(_, o, _) -> isNothing o) rows `shouldBe` True + + it "worker A claims all N when free; B claims 0 while A holds valid leases" $ \store -> do + Right claimedA <- Store.runStoreIO store $ Store.runTransaction $ do + ensureShardRows subName 4 + claimShardsTx subName wA 4 t0 ttl + claimedA `shouldBe` [0, 1, 2, 3] + Right claimedB <- Store.runStoreIO store $ Store.runTransaction (claimShardsTx subName wB 4 t0 ttl) + claimedB `shouldBe` [] + + it "B claims A's buckets after A's lease expires; A then renews nothing" $ \store -> do + Right _ <- Store.runStoreIO store $ Store.runTransaction $ do + ensureShardRows subName 4 + claimShardsTx subName wA 4 t0 ttl + Right claimedB <- Store.runStoreIO store $ Store.runTransaction (claimShardsTx subName wB 4 tExpired ttl) + claimedB `shouldBe` [0, 1, 2, 3] + -- A lost every bucket to B, so its renew returns the empty set: this is how + -- a worker learns it no longer owns a bucket and stops reading it. + Right heldA <- Store.runStoreIO store $ Store.runTransaction (renewLeaseTx subName wA tExpired ttl) + heldA `shouldBe` [] + + it "renewLease returns only still-held buckets" $ \store -> do + Right held <- Store.runStoreIO store $ Store.runTransaction $ do + ensureShardRows subName 4 + _ <- claimShardsTx subName wA 4 t0 ttl + renewLeaseTx subName wA t0 ttl + held `shouldBe` [0, 1, 2, 3] + + it "releaseShards: relinquished buckets are immediately claimable" $ \store -> do + Right _ <- Store.runStoreIO store $ Store.runTransaction $ do + ensureShardRows subName 4 + _ <- claimShardsTx subName wA 4 t0 ttl + releaseShardsTx subName wA [0, 1] + -- Even while A's lease over 2,3 is still valid, the released 0,1 are claimable. + Right claimedB <- Store.runStoreIO store $ Store.runTransaction (claimShardsTx subName wB 4 t0 ttl) + claimedB `shouldBe` [0, 1] + + it "fairShareTarget divides buckets evenly (ceil)" $ \_store -> do + fairShareTarget 6 3 `shouldBe` 2 + fairShareTarget 6 4 `shouldBe` 2 + fairShareTarget 7 3 `shouldBe` 3 + fairShareTarget 4 0 `shouldBe` 4 -- a non-positive estimate claims everything + it "acquireOutcome keeps previous ownership on acquire failure" $ \_store -> do + let previous = Set.fromList [0, 2] + acquireOutcome previous (Left "database unavailable") + `shouldBe` (previous, Just (ShardAcquireFailed "database unavailable")) + acquireOutcome previous (Right (Set.fromList [1, 3])) + `shouldBe` (Set.fromList [1, 3], Nothing) + + it "ensureShards rejects a shardCount mismatch" $ \store -> do + let lease4 = + ShardLease + { subscriptionName = subName, + workerId = wA, + shardCount = 4, + leaseTtl = ttl + } + lease6 = + ShardLease + { subscriptionName = subName, + workerId = wA, + shardCount = 6, + leaseTtl = ttl + } + Right () <- Store.runStoreIO store (ensureShards lease4) + Store.runStoreIO store (ensureShards lease6) + `shouldThrow` \case + ShardCountMismatch name configured found -> + name == "orders-shard" && configured == 6 && found == [4] + + describe "Sharded subscription single worker" $ around (withFreshStore fixture) $ do + -- EP-51 M3: one process owning all N buckets drains a seeded category exactly + -- once. The sink is idempotent on event_id, so "count == total" proves every + -- event was delivered with none missing and none surviving as a duplicate row. + it "one worker with N=4 buckets drains a seeded category exactly once" $ \store -> do + Right () <- Store.runStoreIO store $ Store.runTransaction (Tx.sql createShardSinkSql) + total <- seedOrders store 8 5 -- 40 events across 8 streams + let opts = + (defaultShardedWorkerOptions (Category (CategoryName "orders")) 4) + { leaseTtl = 3, + renewInterval = 0.3 + } + w <- forkIO (runShardedSubscriptionGroup store (SubscriptionName "orders-sub") opts (sinkHandler store 1)) + drained <- waitUntilSinkCount store total 20_000_000 + killThread w + drained `shouldBe` True + count <- shardSinkCount store + count `shouldBe` total + maxW <- maxWorkersPerStream store + maxW `shouldBe` 1 + + describe "Sharded subscription drain and failover" $ around (withFreshStore fixture) $ do + -- EP-51 M5: the behavioural acceptance. Three worker processes cooperatively + -- partition a category; we let ownership converge on the *empty* category + -- first (so the churn of cold-start rebalancing touches no events), then seed + -- and drain under stable membership — so each stream is owned by exactly one + -- worker throughout the drain. Then we kill a worker and prove its buckets are + -- re-homed and the new events drain (failover via lease expiry). + let sub = SubscriptionName "orders-failover" + mkOpts = (defaultShardedWorkerOptions (Category (CategoryName "orders")) 6) {leaseTtl = 3, renewInterval = 0.3} + it "three workers drain disjointly, then re-home a killed worker's buckets" $ \store -> do + Right () <- Store.runStoreIO store $ Store.runTransaction (Tx.sql createShardSinkSql) + w1 <- forkIO (runShardedSubscriptionGroup store sub mkOpts (sinkHandler store 1)) + w2 <- forkIO (runShardedSubscriptionGroup store sub mkOpts (sinkHandler store 2)) + w3 <- forkIO (runShardedSubscriptionGroup store sub mkOpts (sinkHandler store 3)) + -- Wait for cooperative balance on the empty category: all 6 buckets owned, + -- spread across >= 2 workers, none holding more than its fair share. + balanced <- waitShardsBalanced store sub 6 2 15_000_000 + balanced `shouldBe` True + -- Now seed and drain under stable membership. + total1 <- seedOrders store 12 5 -- 60 events + ok1 <- waitUntilSinkCount store total1 25_000_000 + ok1 `shouldBe` True + -- Disjoint: no stream key was processed by two workers (stable membership, + -- so no re-homing split any stream). + maxW <- maxWorkersPerStream store + maxW `shouldBe` 1 + -- The work genuinely spread (not a monopoly): at least two workers participated. + spread <- distinctWorkers store + spread `shouldSatisfy` (>= 2) + -- Counts sum to total with no duplicate event id (PK on event_id + count). + c1 <- shardSinkCount store + c1 `shouldBe` total1 + -- Kill worker 1 (its readers stop; it stops renewing, so its leases expire). + killThread w1 + -- Seed more across all streams; some hash to worker 1's now-orphaned buckets. + total2 <- seedOrders store 12 5 -- another 60 + -- Failover: a surviving worker re-claims the expired buckets and drains the + -- new events. If re-homing did not happen, events on worker 1's buckets would + -- never drain and this would time out. + ok2 <- waitUntilSinkCount store (total1 + total2) 30_000_000 + killThread w2 + killThread w3 + ok2 `shouldBe` True + c2 <- shardSinkCount store + c2 `shouldBe` (total1 + total2) + + it "a killed worker relinquishes its leases immediately" $ \store -> do + let subImmediate = SubscriptionName "orders-immediate-release" + longTtlOpts = + (defaultShardedWorkerOptions (Category (CategoryName "orders")) 4) + { leaseTtl = 30, + renewInterval = 0.2 + } + w <- forkIO (runShardedSubscriptionGroup store subImmediate longTtlOpts (sinkHandler store 1)) + owned <- waitShardsBalanced store subImmediate 4 1 10_000_000 + owned `shouldBe` True + killThread w + released <- waitShardsUnowned store subImmediate 4 3_000_000 + released `shouldBe` True + + it "a handler exception is retried in place and drains" $ \store -> do + Right () <- Store.runStoreIO store $ Store.runTransaction (Tx.sql createShardSinkSql) + thrown <- newIORef False + errors <- newIORef [] + let subRestart = SubscriptionName "orders-reader-restart" + opts = + (defaultShardedWorkerOptions (Category (CategoryName "orders")) 2) + { leaseTtl = 3, + renewInterval = 0.2, + handlerRetryDelay = KirokuSub.RetryDelay 0.05, + onShardError = Just (\err -> modifyIORef' errors (err :)) + } + handler ev = do + firstTime <- + atomicModifyIORef' + thrown + ( \seen -> + if seen + then (seen, False) + else (True, True) + ) + when firstTime (throwIO (userError "reader boom")) + sinkHandler store 1 ev + w <- forkIO (runShardedSubscriptionGroup store subRestart opts handler) + balanced <- waitShardsBalanced store subRestart 2 1 10_000_000 + balanced `shouldBe` True + total <- seedOrders store 4 2 + drained <- waitUntilSinkCount store total 20_000_000 + killThread w + drained `shouldBe` True + seenErrors <- readIORef errors + seenErrors `shouldSatisfy` all (\case ShardReaderDied _ _ -> False; _ -> True) + + describe "Sharded subscription ack coupling" $ around (withFreshStore fixture) $ do + it "redelivers a batch-tail event whose handler was killed mid-flight" $ \store -> do + Right () <- Store.runStoreIO store $ Store.runTransaction (Tx.sql createShardSinkSql) + total <- seedOrders store 1 5 + enteredTail <- newEmptyMVar + holdTail <- newEmptyMVar + let sub = SubscriptionName "orders-ack-tail" + opts = + (defaultShardedWorkerOptions (Category (CategoryName "orders")) 1) + { leaseTtl = 3, + renewInterval = 0.3 + } + blockingHandler ev = do + let orderNumber = parseEither (withObject "OrderPlaced" (.: "n")) (ev ^. #payload) + when (orderNumber == Right (4 :: Int)) $ do + putMVar enteredTail () + takeMVar holdTail + sinkHandler store 1 ev + first <- forkIO (runShardedSubscriptionGroup store sub opts blockingHandler) + entered <- timeout 10_000_000 (takeMVar enteredTail) + entered `shouldBe` Just () + -- The old pull bridge replies Continue before invoking the handler; + -- leave enough time for its batch-tail checkpoint to commit while the + -- handler remains blocked. The ack-coupled bridge introduced by EP-96 + -- remains blocked on the unfilled reply instead. + threadDelay 200_000 + killThread first + second <- forkIO (runShardedSubscriptionGroup store sub opts (sinkHandler store 2)) + drained <- waitUntilSinkCount store total 20_000_000 + killThread second + drained `shouldBe` True + shardSinkCount store `shouldReturn` total + + it "loses no events when a bucket is shed mid-drain during rebalance" $ \store -> do + Right () <- Store.runStoreIO store $ Store.runTransaction (Tx.sql createShardSinkSql) + total <- seedOrders store 24 5 + let sub = SubscriptionName "orders-ack-rebalance" + opts = + (defaultShardedWorkerOptions (Category (CategoryName "orders")) 4) + { leaseTtl = 3, + renewInterval = 0.3, + batchSize = 1 + } + slowHandler tag ev = do + threadDelay 100_000 + sinkHandler store tag ev + first <- forkIO (runShardedSubscriptionGroup store sub opts (slowHandler 1)) + -- acquireOwnedBuckets claims one bucket per pass. Starting the joiner + -- while A owns three leaves one claimable bucket for B, making B visible; + -- A's next pass then sheds its excess third bucket while its handler is + -- deliberately slow and in flight. + ownsThree <- waitUntilOwnedShardCount store sub 3 10_000_000 + ownsThree `shouldBe` True + second <- forkIO (runShardedSubscriptionGroup store sub opts (slowHandler 2)) + drained <- waitUntilSinkCount store total 30_000_000 + killThread first + killThread second + drained `shouldBe` True + shardSinkCount store `shouldReturn` total + + it "allows zombie overlap duplicates without losing an event" $ \store -> do + Right () <- Store.runStoreIO store $ Store.runTransaction (Tx.sql createShardSinkSql) + total <- seedOrders store 1 5 + entered <- newEmptyMVar + release <- newEmptyMVar + deliveries <- newIORef ([] :: [EventId]) + successor <- newIORef Nothing + readersA <- newIORef Map.empty + let sub = SubscriptionName "orders-ack-zombie" + opts = + (defaultShardedWorkerOptions (Category (CategoryName "orders")) 1) + { leaseTtl = 2, + renewInterval = 0.2 + } + leaseA = + ShardLease + { subscriptionName = sub, + workerId = WorkerId sampleUuid, + shardCount = 1, + leaseTtl = 2 + } + handlerA delivery = do + let ev = delivery ^. #event + modifyIORef' deliveries ((ev ^. #eventId) :) + putMVar entered () + takeMVar release + sinkHandler store 1 ev + pure ShardAckOk + handlerB delivery = do + let ev = delivery ^. #event + modifyIORef' deliveries ((ev ^. #eventId) :) + sinkHandler store 2 ev + pure ShardAckOk + cleanup = do + void (tryPutMVar release ()) + mSuccessor <- readIORef successor + for_ mSuccessor killThread + now <- getCurrentTime + let cleanupWorker = WorkerId sampleUuid2 + _ <- Store.runStoreIO store $ Store.runTransaction $ do + releaseShardsTx sub (WorkerId sampleUuid) [0] + claimShardsTx sub cleanupWorker 1 now 30 + void (reconcileShardsOnce store leaseA opts readersA handlerA) + ( do + Right () <- Store.runStoreIO store (ensureShards leaseA) + void (reconcileShardsOnce store leaseA opts readersA handlerA) + timeout 10_000_000 (takeMVar entered) `shouldReturn` Just () + -- A no longer renews, but its reader remains alive and blocked + -- with one unacknowledged event. B can claim after expiry and + -- must therefore receive that event again from the checkpoint. + threadDelay 2_500_000 + workerB <- forkIO (runShardedSubscriptionGroupAck store sub opts handlerB) + writeIORef successor (Just workerB) + drained <- waitUntilSinkCount store total 20_000_000 + drained `shouldBe` True + raw <- readIORef deliveries + length raw `shouldSatisfy` (> total) + shardSinkCount store `shouldReturn` total + ) + `finally` cleanup + + it "dead-letters a poison event after bounded retries and keeps draining" $ \store -> do + Right () <- Store.runStoreIO store $ Store.runTransaction (Tx.sql createShardSinkSql) + total <- seedOrders store 1 4 + poisonDeliveries <- newIORef (0 :: Int) + errors <- newIORef [] + let sub = SubscriptionName "orders-ack-poison" + opts = + (defaultShardedWorkerOptions (Category (CategoryName "orders")) 1) + { leaseTtl = 3, + renewInterval = 0.2, + handlerRetryDelay = KirokuSub.RetryDelay 0.05, + retryPolicy = KirokuSub.RetryPolicy 3, + onShardError = Just (\err -> modifyIORef' errors (err :)) + } + handler ev = do + let orderNumber = parseEither (withObject "OrderPlaced" (.: "n")) (ev ^. #payload) + if orderNumber == Right (1 :: Int) + then do + modifyIORef' poisonDeliveries (+ 1) + throwIO (userError "poison order") + else sinkHandler store 1 ev + worker <- forkIO (runShardedSubscriptionGroup store sub opts handler) + drained <- waitUntilSinkCount store (total - 1) 20_000_000 + details <- shardDeadLetterDetails store "orders-ack-poison" + attempts <- readIORef poisonDeliveries + seenErrors <- readIORef errors + killThread worker + drained `shouldBe` True + attempts `shouldBe` 3 + details `shouldBe` (1, Just "max retry attempts exceeded (3)", Just 3) + seenErrors `shouldSatisfy` all (\case ShardReaderDied _ _ -> False; _ -> True) + + describe "Keiro.Workflow observability" $ around (withFreshStore fixture) $ do + -- The headline operability signal: executed (real work) vs replayed + -- (recorded history), recorded by the runtime through an SDK meter and read + -- back from the in-memory exporter — plus the active gauge and the + -- journal-length histogram. + it "records workflow instruments through an SDK meter" $ \storeHandle -> do + (exporter, ref) <- inMemoryMetricExporter + (provider, _env) <- + createMeterProvider + emptyMaterializedResources + defaultSdkMeterProviderOptions {metricExporter = Just exporter} + meter <- getMeter provider Telemetry.keiroInstrumentationLibrary + metrics <- Telemetry.newKeiroMetrics meter + counter <- newIORef (0 :: Int) + let name = WorkflowName "obs" + wid = WorkflowId "obs-1" + opts = defaultWorkflowRunOptions & #metrics .~ Just metrics + -- First run: both steps miss → two executions. + first <- Store.runStoreIO storeHandle $ runWorkflowWith opts name wid (demoWorkflow counter) + first `shouldBe` Right (Completed (1, 2)) + -- Second run, same id: both steps hit → two replays. + second <- Store.runStoreIO storeHandle $ runWorkflowWith opts name wid (demoWorkflow counter) + second `shouldBe` Right (Completed (1, 2)) + -- The side effects ran exactly twice across both runs (the replay run + -- short-circuited every step). + readIORef counter >>= \c -> c `shouldBe` 2 + _ <- forceFlushMeterProvider provider Nothing + exported <- readIORef ref + let scalars = flattenScalarPoints exported + hists = flattenHistogramPoints exported + lookup "keiro.workflow.steps.executed" scalars `shouldBe` Just (IntNumber 2) + lookup "keiro.workflow.steps.replayed" scalars `shouldBe` Just (IntNumber 2) + -- One journal-length observation per completed run (two completions). + [c | (n, c, _) <- hists, n == "keiro.workflow.journal.length"] `shouldBe` [2] + -- Both runs finished, so the live-run count returned to zero. + lookup "keiro.workflow.active" scalars `shouldBe` Just (IntNumber 0) + + -- The resume worker increments keiro.workflow.resumed per re-invocation and + -- samples keiro.workflow.awakeables.pending each pass. + it "records a resume and the pending-awakeable count when the worker re-invokes" $ \storeHandle -> do + (exporter, ref) <- inMemoryMetricExporter + (provider, _env) <- + createMeterProvider + emptyMaterializedResources + defaultSdkMeterProviderOptions {metricExporter = Just exporter} + meter <- getMeter provider Telemetry.keiroInstrumentationLibrary + metrics <- Telemetry.newKeiroMetrics meter + counter <- newIORef (0 :: Int) + let name = WorkflowName "obs-resume" + wid = WorkflowId "obs-r-1" + -- Suspend a workflow so it has a step row but no completion: the resume + -- worker will re-invoke it (and stay Suspended, which still counts as a + -- re-invocation). + suspended <- Store.runStoreIO storeHandle $ runWorkflow name wid (stepThenAwaitWorkflow counter) + suspended `shouldBe` Right Suspended + -- Register one pending awakeable (independent of the suspended workflow's + -- own await) so the pending gauge has something to count. + let aid = awakeableIdToUuid (deterministicAwakeableId (WorkflowName "ext") (WorkflowId "1") "cb") + Right () <- + Store.runStoreIO storeHandle $ Store.runTransaction $ Awk.registerAwakeableTx aid "ext" "1" + -- One resume pass with metrics threaded through the run options. + let registry = Map.singleton name (WorkflowDef (\_wid -> stepThenAwaitWorkflow counter)) + resumeOpts = + defaultWorkflowResumeOptions + & #runOptions + .~ (defaultWorkflowRunOptions & #metrics .~ Just metrics) + Right _summary <- Store.runStoreIO storeHandle $ resumeWorkflowsOnce resumeOpts registry + _ <- forceFlushMeterProvider provider Nothing + exported <- readIORef ref + let scalars = flattenScalarPoints exported + lookup "keiro.workflow.resumed" scalars `shouldBe` Just (IntNumber 1) + lookup "keiro.workflow.awakeables.pending" scalars `shouldBe` Just (IntNumber 1) + + -- The no-op idiom end to end: defaultWorkflowRunOptions carries metrics = + -- Nothing, so a run on a dedicated provider exports no points at all. + it "records nothing through a Nothing handle" $ \storeHandle -> do + (exporter, ref) <- inMemoryMetricExporter + (provider, _env) <- + createMeterProvider + emptyMaterializedResources + defaultSdkMeterProviderOptions {metricExporter = Just exporter} + counter <- newIORef (0 :: Int) + result <- + Store.runStoreIO storeHandle $ + runWorkflow (WorkflowName "obs-noop") (WorkflowId "obs-n-1") (demoWorkflow counter) + result `shouldBe` Right (Completed (1, 2)) + _ <- forceFlushMeterProvider provider Nothing + exported <- readIORef ref + flattenScalarPoints exported `shouldBe` [] + flattenHistogramPoints exported `shouldBe` [] + + describe "Keiro.Workflow.Snapshot codec" $ do + -- Pure (no-DB) round-trip of the workflow state codec. + it "round-trips a non-trivial accumulated step map and carries the sentinel shape hash" $ do + let m = + Map.fromList + [ ("first", toJSON (1 :: Int)), + ("second", toJSON ["a", "b" :: Text]), + ("sleep:42", Aeson.Null) + ] + (workflowStateCodec ^. #decode) ((workflowStateCodec ^. #encode) m) `shouldBe` Right m + (workflowStateCodec ^. #shapeHash) `shouldBe` "keiro.workflow.stepmap.v1" + (workflowStateCodec ^. #stateShapeHash) `shouldBe` "keiro.workflow.stepmap.v1" + (workflowStateCodec ^. #stateCodecVersion) `shouldBe` 1 + + describe "Keiro.Workflow.Types journal codec" $ do + -- Pure (no-DB) round-trip of the EP-48 rotation marker, proving the + -- additive WorkflowContinuedAsNew constructor encodes and decodes + -- self-describingly within schemaVersion 1. + it "round-trips a WorkflowContinuedAsNew rotation marker" $ do + let t = UTCTime (ModifiedJulianDay 60000) (secondsToDiffTime 3600) + marker = WorkflowContinuedAsNew 3 t + (workflowJournalCodec ^. #decode) ((workflowJournalCodec ^. #eventType) marker) ((workflowJournalCodec ^. #encode) marker) + `shouldBe` Right marker + (workflowJournalCodec ^. #schemaVersion) `shouldBe` 1 + EventType "WorkflowContinuedAsNew" `elem` (workflowJournalCodec ^. #eventTypes) `shouldBe` True + + it "validates workflow identity smart constructors" $ do + mkWorkflowName "orderFulfillment" `shouldBe` Right (WorkflowName "orderFulfillment") + mkWorkflowName "" `shouldBe` Left WorkflowNameEmpty + mkWorkflowName "order-fulfillment" `shouldBe` Left (WorkflowNameInvalidChar '-' "order-fulfillment") + mkWorkflowName "order:fulfillment" `shouldBe` Left (WorkflowNameInvalidChar ':' "order:fulfillment") + mkWorkflowName "order#1" `shouldBe` Left (WorkflowNameInvalidChar '#' "order#1") + mkWorkflowId "550e8400-e29b-41d4-a716-446655440000" + `shouldBe` Right (WorkflowId "550e8400-e29b-41d4-a716-446655440000") + mkWorkflowId "" `shouldBe` Left WorkflowIdEmpty + mkWorkflowId "customer:42" `shouldBe` Left (WorkflowIdInvalidChar ':' "customer:42") + mkWorkflowId "customer#42" `shouldBe` Left (WorkflowIdInvalidChar '#' "customer#42") + + describe "Keiro.Workflow.Sleep" $ do + -- Pure (no-DB) checks of the id/payload/step-name helpers. + it "derives a deterministic, distinct timer id" $ do + let name = WorkflowName "wf" + wid = WorkflowId "w-1" + sleepGolden = uuidLiteral "a95d5e7f-a43d-5ee2-9243-8206f0d8734a" + sleepTimerId name wid 0 "sleep:cool" `shouldBe` sleepTimerId name wid 0 "sleep:cool" + (sleepTimerId name wid 0 "sleep:cool" == sleepTimerId name wid 0 "sleep:other") + `shouldBe` False + sleepTimerId name wid 0 "sleep:cool" + `shouldBe` TimerId sleepGolden + sleepTimerId name wid 1 "sleep:cool" `shouldNotBe` sleepTimerId name wid 0 "sleep:cool" + sleepTimerId name wid 2 "sleep:cool" `shouldNotBe` sleepTimerId name wid 1 "sleep:cool" + + it "round-trips and recognises its timer payload" $ do + parseSleepPayload (sleepTimerPayload 2 "sleep:cool") + `shouldBe` Just ("sleep:cool", Just 2) + parseSleepPayload + ( object + [ "kind" Aeson..= ("keiro.workflow.sleep" :: Text), + "step" Aeson..= ("sleep:legacy" :: Text) + ] + ) + `shouldBe` Just ("sleep:legacy", Nothing) + parseSleepPayload (object ["kind" Aeson..= ("counter-timeout" :: Text)]) + `shouldBe` Nothing + + it "recovers a legacy payload's generation from its deterministic timer id" $ do + let name = WorkflowName "wf" + wid = WorkflowId "w-legacy" + full = "sleep:cool" + for_ [0 .. 2] $ \gen -> + matchSleepTimerGeneration name wid 2 full (sleepTimerId name wid gen full) + `shouldBe` Just gen + + it "prefixes the journal step name with the reserved sleep prefix" $ + sleepStepName (StepName "cool") `shouldBe` "sleep:cool" + + around (withFreshStore fixture) $ do + it "arms a timer and suspends, then a fired timer resumes the workflow" $ \storeHandle -> do + counter <- newIORef (0 :: Int) + let name = WorkflowName "sleepdemo" + wid = WorkflowId "sd-1" + journalStream = StreamName "wf:sleepdemo-sd-1" + TimerId timerUuid = sleepTimerId name wid 0 "sleep:cool" + -- First run: 'a' runs, the sleep arms a timer, and the run suspends. + outcome1 <- + Store.runStoreIO storeHandle $ + runWorkflow name wid (sleepDemoNamed counter (StepName "cool") 0) + outcome1 `shouldBe` Right Suspended + afterFirst <- readIORef counter + afterFirst `shouldBe` 1 + -- The journal holds only 'a' (no completion, no sleep:cool yet). + Right recorded1 <- + Store.runStoreIO storeHandle $ + Store.readStreamForward journalStream (StreamVersion 0) 100 + traverse (decodeRecorded workflowJournalCodec) (Vector.toList recorded1) + `shouldSatisfy` \case + Right [StepRecorded "a" _ _] -> True + _ -> False + -- The durable wait is a single Scheduled timer row carrying the + -- workflow-sleep payload. + Right timerRow <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + Tx.statement timerUuid sleepTimerStatusStmt + timerRow `shouldSatisfy` \case + Just (status, payload) -> + status == "scheduled" + && parseSleepPayload payload == Just ("sleep:cool", Just 0) + Nothing -> False + -- Fire the timer through the routing worker (no PM fallback needed). + fireTime <- getCurrentTime + fireResult <- + Store.runStoreIO storeHandle $ + runWorkflowTimerWorker Nothing fireTime (\_ -> pure Nothing) + case fireResult of + Right (Just timer) -> timer ^. #status `shouldBe` Firing + other -> expectationFailure ("expected a fired sleep timer, got " <> show other) + -- The row is now Fired and the journal gained sleep:cool. + Right afterFire <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + Tx.statement timerUuid sleepTimerStatusStmt + fmap fst afterFire `shouldBe` Just "fired" + Right recorded2 <- + Store.runStoreIO storeHandle $ + Store.readStreamForward journalStream (StreamVersion 0) 100 + traverse (decodeRecorded workflowJournalCodec) (Vector.toList recorded2) + `shouldSatisfy` \case + Right [StepRecorded "a" _ _, StepRecorded "sleep:cool" _ _] -> True + _ -> False + -- Second run completes: 'a' and the sleep short-circuit, only 'b' runs. + outcome2 <- + Store.runStoreIO storeHandle $ + runWorkflow name wid (sleepDemoNamed counter (StepName "cool") 0) + outcome2 `shouldBe` Right (Completed (1, 2)) + afterSecond <- readIORef counter + afterSecond `shouldBe` 2 + Right recorded3 <- + Store.runStoreIO storeHandle $ + Store.readStreamForward journalStream (StreamVersion 0) 100 + traverse (decodeRecorded workflowJournalCodec) (Vector.toList recorded3) + `shouldSatisfy` \case + Right [StepRecorded "a" _ _, StepRecorded "sleep:cool" _ _, StepRecorded "b" _ _, WorkflowCompleted _] -> True + _ -> False + + it "respects a positive delay: not due before fire_at, fires after" $ \storeHandle -> do + counter <- newIORef (0 :: Int) + let name = WorkflowName "sleepwait" + wid = WorkflowId "rt-1" + journalStream = StreamName "wf:sleepwait-rt-1" + clockBeforeFire <- getCurrentTime + outcome1 <- + Store.runStoreIO storeHandle $ + runWorkflow name wid (sleepDemoNamed counter (StepName "wait") 1) + outcome1 `shouldBe` Right Suspended + afterFirst <- readIORef counter + afterFirst `shouldBe` 1 + -- A worker whose clock is before fire_at claims nothing. + notDue <- + Store.runStoreIO storeHandle $ + runTimerWorker Nothing clockBeforeFire workflowSleepFireAction + notDue `shouldBe` Right Nothing + Right recordedMid <- + Store.runStoreIO storeHandle $ + Store.readStreamForward journalStream (StreamVersion 0) 100 + traverse (decodeRecorded workflowJournalCodec) (Vector.toList recordedMid) + `shouldSatisfy` \case + Right [StepRecorded "a" _ _] -> True + _ -> False + -- Wait out the one-second delay, then the worker fires it. + threadDelay 1_200_000 + afterDelay <- getCurrentTime + fired <- + Store.runStoreIO storeHandle $ + runTimerWorker Nothing afterDelay workflowSleepFireAction + fired `shouldSatisfy` \case + Right (Just _) -> True + _ -> False + Right recordedWoken <- + Store.runStoreIO storeHandle $ + Store.readStreamForward journalStream (StreamVersion 0) 100 + traverse (decodeRecorded workflowJournalCodec) (Vector.toList recordedWoken) + `shouldSatisfy` \case + Right [StepRecorded "a" _ _, StepRecorded "sleep:wait" _ _] -> True + _ -> False + outcome2 <- + Store.runStoreIO storeHandle $ + runWorkflow name wid (sleepDemoNamed counter (StepName "wait") 1) + outcome2 `shouldBe` Right (Completed (1, 2)) + afterSecond <- readIORef counter + afterSecond `shouldBe` 2 + + it "does not postpone fire_at when a resume pass re-arms the sleep" $ \storeHandle -> do + counter <- newIORef (0 :: Int) + let name = WorkflowName "sleeponce" + wid = WorkflowId "so-1" + TimerId timerUuid = sleepTimerId name wid 0 "sleep:cool" + registry = Map.singleton name (WorkflowDef (\_ -> sleepDemoNamed counter (StepName "cool") 300)) + Right Suspended <- + Store.runStoreIO storeHandle $ + runWorkflow name wid (sleepDemoNamed counter (StepName "cool") 300) + Right (Just firstFireAt) <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + Tx.statement timerUuid sleepTimerFireAtStmt + Right summary <- + Store.runStoreIO storeHandle $ + resumeWorkflowsOnce defaultWorkflowResumeOptions registry + discovered summary `shouldBe` 0 + Right (Just secondFireAt) <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + Tx.statement timerUuid sleepTimerFireAtStmt + secondFireAt `shouldBe` firstFireAt + readIORef counter >>= (`shouldBe` 1) + + it "keeps a due wake_after stable on re-arm and clears it on fire" $ \storeHandle -> do + counter <- newIORef (0 :: Int) + let name = WorkflowName "sleep-wake-stable" + wid = WorkflowId "sws-1" + registry = Map.singleton name (WorkflowDef (\_ -> sleepDemoNamed counter (StepName "wait") 0)) + Right Suspended <- + Store.runStoreIO storeHandle $ + runWorkflow name wid (sleepDemoNamed counter (StepName "wait") 0) + Right (Just firstWakeAfter) <- + Store.runStoreIO storeHandle $ + workflowWakeAfter name wid + + Right rearmed <- + Store.runStoreIO storeHandle $ + resumeWorkflowsOnce defaultWorkflowResumeOptions registry + discovered rearmed `shouldBe` 1 + Right (Just secondWakeAfter) <- + Store.runStoreIO storeHandle $ + workflowWakeAfter name wid + secondWakeAfter `shouldBe` firstWakeAfter + + fireTime <- getCurrentTime + Right (Just _) <- + Store.runStoreIO storeHandle $ + runWorkflowTimerWorker Nothing fireTime (\_ -> pure Nothing) + Right clearedWakeAfter <- + Store.runStoreIO storeHandle $ + workflowWakeAfter name wid + clearedWakeAfter `shouldBe` Nothing + + Right resumed <- + Store.runStoreIO storeHandle $ + resumeWorkflowsOnce defaultWorkflowResumeOptions registry + discovered resumed `shouldBe` 1 + completed resumed `shouldBe` 1 + readIORef counter >>= (`shouldBe` 2) + + it "skips a sleeping workflow until wake_after expires" $ \storeHandle -> do + counter <- newIORef (0 :: Int) + let name = WorkflowName "sleepwakeafter" + wid = WorkflowId "swa-1" + Right Suspended <- + Store.runStoreIO storeHandle $ + runWorkflow name wid (sleepDemoNamed counter (StepName "wait") 60) + now <- getCurrentTime + Right mWakeAfter <- Store.runStoreIO storeHandle $ workflowWakeAfter name wid + case mWakeAfter of + Nothing -> expectationFailure "expected wake_after" + Just wakeAfter -> wakeAfter `shouldSatisfy` (> now) + Right early <- Store.runStoreIO storeHandle $ findUnfinishedWorkflowIds now + early `shouldBe` [] + Right due <- Store.runStoreIO storeHandle $ findUnfinishedWorkflowIds (addUTCTime 61 now) + due `shouldBe` [("swa-1", "sleepwakeafter")] + + it "does not re-invoke a parked sleeper before wake_after" $ \storeHandle -> do + counter <- newIORef (0 :: Int) + let name = WorkflowName "sleepquiet" + wid = WorkflowId "sq-1" + registry = Map.singleton name (WorkflowDef (\_ -> sleepDemoNamed counter (StepName "wait") 60)) + pass = Store.runStoreIO storeHandle (resumeWorkflowsOnce defaultWorkflowResumeOptions registry) + Right Suspended <- + Store.runStoreIO storeHandle $ + runWorkflow name wid (sleepDemoNamed counter (StepName "wait") 60) + Right s1 <- pass + Right s2 <- pass + Right s3 <- pass + map discovered [s1, s2, s3] `shouldBe` [0, 0, 0] + readIORef counter >>= (`shouldBe` 1) + + it "treats a missing instance row during sleep arm as a no-op wake hint update" $ \storeHandle -> do + let name = WorkflowName "sleepmissingrow" + wid = WorkflowId "smr-1" + body = sleepNamed (StepName "wait") 60 >> pure () + Right Suspended <- Store.runStoreIO storeHandle $ runWorkflow name wid body + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + Tx.statement ("smr-1", "sleepmissingrow") deleteWorkflowInstanceStmt + Store.runStoreIO storeHandle (runWorkflow name wid body) + `shouldReturn` Right Suspended + + it "fires a sleep whose instance row is missing after an arm crash" $ \storeHandle -> do + let name = WorkflowName "sleep-missing-fire" + wid = WorkflowId "smf-1" + body = sleepNamed (StepName "wait") 0 + Right Suspended <- Store.runStoreIO storeHandle $ runWorkflow name wid body + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + Tx.statement ("smf-1", "sleep-missing-fire") deleteWorkflowInstanceStmt + fireTime <- getCurrentTime + Right (Just _) <- + Store.runStoreIO storeHandle $ + runWorkflowTimerWorker Nothing fireTime (\_ -> pure Nothing) + Right resolved <- + Store.runStoreIO storeHandle $ + stepExists name wid 0 "sleep:wait" + resolved `shouldBe` True + Right (Just recovered) <- + Store.runStoreIO storeHandle $ + Instance.lookupInstance name wid + recovered ^. #status `shouldBe` Instance.WfRunning + Store.runStoreIO storeHandle (runWorkflow name wid body) + `shouldReturn` Right (Completed ()) + + it "fires a sleep longer than the resume cadence under an active resume worker" $ \storeHandle -> do + counter <- newIORef (0 :: Int) + let name = WorkflowName "sleepactive" + wid = WorkflowId "sa-1" + registry = Map.singleton name (WorkflowDef (\_ -> sleepDemoNamed counter (StepName "wait") 1)) + Right Suspended <- + Store.runStoreIO storeHandle $ + runWorkflow name wid (sleepDemoNamed counter (StepName "wait") 1) + threadDelay 1_200_000 + Right boundaryPass <- + Store.runStoreIO storeHandle $ + resumeWorkflowsOnce defaultWorkflowResumeOptions registry + discovered boundaryPass `shouldBe` 1 + fireTime <- getCurrentTime + Right (Just _) <- + Store.runStoreIO storeHandle $ + runWorkflowTimerWorker Nothing fireTime (\_ -> pure Nothing) + Right completionPass <- + Store.runStoreIO storeHandle $ + resumeWorkflowsOnce defaultWorkflowResumeOptions registry + discovered completionPass `shouldBe` 1 + completed completionPass `shouldBe` 1 + readIORef counter >>= (`shouldBe` 2) + + it "uses generation-namespaced timer ids after continueAsNew" $ \storeHandle -> do + counter <- newIORef (0 :: Int) + let name = WorkflowName "sleeproll" + wid = WorkflowId "sr-1" + registry = Map.singleton name (WorkflowDef (\_ -> rollingSleepWorkflow counter)) + drive 0 = expectationFailure "rolling sleep did not complete" + drive n = do + Right summary <- + Store.runStoreIO storeHandle $ + resumeWorkflowsOnce defaultWorkflowResumeOptions registry + now <- getCurrentTime + _ <- + Store.runStoreIO storeHandle $ + runWorkflowTimerWorker Nothing now (\_ -> pure Nothing) + if completed summary == 1 + then pure () + else drive (n - 1) + Right Suspended <- Store.runStoreIO storeHandle $ runWorkflow name wid (rollingSleepWorkflow counter) + drive (12 :: Int) + readIORef counter >>= (`shouldBe` 3) + + describe "Keiro.Workflow sleep generation pinning" $ around (withFreshStore fixture) $ do + it "keeps a stale re-fire on the generation that armed the sleep" $ \storeHandle -> do + counter <- newIORef (0 :: Int) + let name = WorkflowName "sleep-generation-pin" + wid = WorkflowId "sgp-1" + full = "sleep:cool" + TimerId generationZeroTimerId = sleepTimerId name wid 0 full + TimerId generationOneTimerId = sleepTimerId name wid 1 full + body = do + seed <- restoreSeed (0 :: Int) + _ <- step (StepName "work") (liftIO (incrementAndRead counter)) + if seed == 0 + then sleepNamed (StepName "cool") 0 >> continueAsNew (1 :: Int) + else sleepNamed (StepName "cool") 3600 >> pure seed + + Right Suspended <- Store.runStoreIO storeHandle $ runWorkflow name wid body + claimTime <- getCurrentTime + Right (Just claimed) <- Store.runStoreIO storeHandle $ claimDueTimer claimTime + claimed ^. #timerId `shouldBe` TimerId generationZeroTimerId + Right (Just _) <- + Store.runStoreIO storeHandle $ + workflowSleepFireAction claimed + + Right ContinuedAsNew <- Store.runStoreIO storeHandle $ runWorkflow name wid body + Right Suspended <- Store.runStoreIO storeHandle $ runWorkflow name wid body + Right (Just generationOneFireAt) <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + Tx.statement generationOneTimerId sleepTimerFireAtStmt + + requeueTime <- getCurrentTime + Right requeued <- + Store.runStoreIO storeHandle $ + requeueStuckTimers 0 (addUTCTime 1 requeueTime) + requeued `shouldBe` 1 + Right (Just staleFire) <- + Store.runStoreIO storeHandle $ + runWorkflowTimerWorker Nothing (addUTCTime 2 requeueTime) (\_ -> pure Nothing) + staleFire ^. #timerId `shouldBe` TimerId generationZeroTimerId + + Right generationOneResolved <- + Store.runStoreIO storeHandle $ + stepExists name wid 1 full + generationOneResolved `shouldBe` False + Right (Just instanceRow) <- + Store.runStoreIO storeHandle $ + Instance.lookupInstance name wid + instanceRow ^. #status `shouldBe` Instance.WfSuspended + Right generationZeroStatus <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + Tx.statement generationZeroTimerId sleepTimerStatusStmt + fmap fst generationZeroStatus `shouldBe` Just "fired" + Right generationOneStatus <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + Tx.statement generationOneTimerId sleepTimerStatusStmt + fmap fst generationOneStatus `shouldBe` Just "scheduled" + Right (Just generationOneFireAtAfter) <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + Tx.statement generationOneTimerId sleepTimerFireAtStmt + generationOneFireAtAfter `shouldBe` generationOneFireAt + readIORef counter >>= (`shouldBe` 2) + + describe "Keiro.Workflow.Awakeable" $ do + -- Pure (no-DB) check of the deterministic id derivation. + it "derives a deterministic AwakeableId, stable across calls and label-sensitive" $ do + let aid1 = deterministicAwakeableId (WorkflowName "w") (WorkflowId "1") "approval" + aid2 = deterministicAwakeableId (WorkflowName "w") (WorkflowId "1") "approval" + aidOther = deterministicAwakeableId (WorkflowName "w") (WorkflowId "1") "other" + awakeableGolden = uuidLiteral "ccaeaf74-3ffe-5ea5-a118-a3441a95c279" + aid1 `shouldBe` aid2 + (aid1 == aidOther) `shouldBe` False + aid1 `shouldBe` AwakeableId awakeableGolden + + around (withFreshStore fixture) $ do + it "schema: registers, completes once (idempotent), cancels, and counts pending rows" $ \storeHandle -> do + let aidA = awakeableIdToUuid (deterministicAwakeableId (WorkflowName "sch") (WorkflowId "1") "a") + aidB = awakeableIdToUuid (deterministicAwakeableId (WorkflowName "sch") (WorkflowId "1") "b") + now <- getCurrentTime + Right () <- Store.runStoreIO storeHandle $ Store.runTransaction $ do + Awk.registerAwakeableTx aidA "sch" "1" + Awk.registerAwakeableTx aidB "sch" "1" + Right pendingCount <- Store.runStoreIO storeHandle Awk.countPendingAwakeables + pendingCount `shouldBe` 2 + Right (Just rowA) <- Store.runStoreIO storeHandle $ Awk.lookupAwakeable aidA + rowA ^. #status `shouldBe` Awk.Pending + rowA ^. #payload `shouldBe` Nothing + -- Complete A once; the status-guarded UPDATE makes a re-complete a no-op. + Right firstComplete <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + Awk.completeAwakeableTx aidA (toJSON ("done" :: Text)) now + firstComplete `shouldBe` True + Right secondComplete <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + Awk.completeAwakeableTx aidA (toJSON ("again" :: Text)) now + secondComplete `shouldBe` False + Right (Just rowA') <- Store.runStoreIO storeHandle $ Awk.lookupAwakeable aidA + rowA' ^. #status `shouldBe` Awk.Completed + rowA' ^. #payload `shouldBe` Just (toJSON ("done" :: Text)) + -- Cancel the still-pending B; both rows are now resolved. + Right cancelled <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + Awk.cancelAwakeableTx aidB + cancelled `shouldBe` True + Right pendingAfter <- Store.runStoreIO storeHandle Awk.countPendingAwakeables + pendingAfter `shouldBe` 0 + + it "suspends on an unsignalled awakeable, recording a pending row and no completion" $ \storeHandle -> do + aidRef <- newIORef Nothing + let name = WorkflowName "approval" + wid = WorkflowId "wf1" + outcome1 <- Store.runStoreIO storeHandle $ runWorkflow name wid (approvalFlowWithId aidRef) + outcome1 `shouldBe` Right Suspended + aid <- readRequiredAwakeableId aidRef + Right (Just row) <- Store.runStoreIO storeHandle $ Awk.lookupAwakeable (awakeableIdToUuid aid) + row ^. #status `shouldBe` Awk.Pending + row ^. #payload `shouldBe` Nothing + Right pendingNow <- Store.runStoreIO storeHandle Awk.countPendingAwakeables + pendingNow `shouldBe` 1 + Right recorded <- + Store.runStoreIO storeHandle $ + Store.readStreamForward (StreamName "wf:approval-wf1") (StreamVersion 0) 100 + traverse (decodeRecorded workflowJournalCodec) (Vector.toList recorded) + `shouldSatisfy` \case + Right [StepRecorded stepName value _] -> + stepName == awakeableAllocStepPrefix <> "approval" && value == toJSON aid + _ -> False + + it "resumes with the signalled payload after signalAwakeable" $ \storeHandle -> do + aidRef <- newIORef Nothing + let name = WorkflowName "approval" + wid = WorkflowId "wf1" + Right Suspended <- Store.runStoreIO storeHandle $ runWorkflow name wid (approvalFlowWithId aidRef) + aid <- readRequiredAwakeableId aidRef + let awkStep = "awk:" <> awakeableIdText aid + Right signalled <- Store.runStoreIO storeHandle $ signalAwakeable aid ("ok" :: Text) + signalled `shouldBe` True + Right (Just row) <- Store.runStoreIO storeHandle $ Awk.lookupAwakeable (awakeableIdToUuid aid) + row ^. #status `shouldBe` Awk.Completed + row ^. #payload `shouldBe` Just (toJSON ("ok" :: Text)) + Right afterSignal <- + Store.runStoreIO storeHandle $ + Store.readStreamForward (StreamName "wf:approval-wf1") (StreamVersion 0) 100 + traverse (decodeRecorded workflowJournalCodec) (Vector.toList afterSignal) + `shouldSatisfy` \case + Right [StepRecorded allocStep _ _, StepRecorded s r _] -> + allocStep == awakeableAllocStepPrefix <> "approval" && s == awkStep && r == toJSON ("ok" :: Text) + _ -> False + outcome2 <- Store.runStoreIO storeHandle $ runWorkflow name wid (approvalFlowWithId aidRef) + outcome2 `shouldBe` Right (Completed "ok!") + Right afterResume <- + Store.runStoreIO storeHandle $ + Store.readStreamForward (StreamName "wf:approval-wf1") (StreamVersion 0) 100 + traverse (decodeRecorded workflowJournalCodec) (Vector.toList afterResume) + `shouldSatisfy` \case + Right [StepRecorded allocStep _ _, StepRecorded s1 _ _, StepRecorded "use" _ _, WorkflowCompleted _] -> + allocStep == awakeableAllocStepPrefix <> "approval" && s1 == awkStep + _ -> False + + it "is idempotent: a second signal returns False and does not change the value" $ \storeHandle -> do + aidRef <- newIORef Nothing + let name = WorkflowName "idem" + wid = WorkflowId "wf-i" + Right Suspended <- Store.runStoreIO storeHandle $ runWorkflow name wid (approvalFlowWithId aidRef) + aid <- readRequiredAwakeableId aidRef + let awkStep = "awk:" <> awakeableIdText aid + Right True <- Store.runStoreIO storeHandle $ signalAwakeable aid ("ok" :: Text) + Right again <- Store.runStoreIO storeHandle $ signalAwakeable aid ("later" :: Text) + again `shouldBe` False + Right (Just row) <- Store.runStoreIO storeHandle $ Awk.lookupAwakeable (awakeableIdToUuid aid) + row ^. #payload `shouldBe` Just (toJSON ("ok" :: Text)) + Right recorded <- + Store.runStoreIO storeHandle $ + Store.readStreamForward (StreamName "wf:idem-wf-i") (StreamVersion 0) 100 + Right decoded <- pure (traverse (decodeRecorded workflowJournalCodec) (Vector.toList recorded)) + [r | StepRecorded s r _ <- decoded, s == awkStep] `shouldBe` [toJSON ("ok" :: Text)] + + it "throws WorkflowAwakeableCancelled after cancelAwakeable" $ \storeHandle -> do + aidRef <- newIORef Nothing + let name = WorkflowName "cancelwf" + wid = WorkflowId "wf2" + Right Suspended <- Store.runStoreIO storeHandle $ runWorkflow name wid (approvalFlowWithId aidRef) + aid <- readRequiredAwakeableId aidRef + Right cancelled <- Store.runStoreIO storeHandle $ cancelAwakeable aid + cancelled `shouldBe` True + Right (Just row) <- Store.runStoreIO storeHandle $ Awk.lookupAwakeable (awakeableIdToUuid aid) + row ^. #status `shouldBe` Awk.Cancelled + Store.runStoreIO storeHandle (runWorkflow name wid (approvalFlowWithId aidRef)) + `shouldThrow` (== WorkflowAwakeableCancelled aid) + Right recorded <- + Store.runStoreIO storeHandle $ + Store.readStreamForward (StreamName "wf:cancelwf-wf2") (StreamVersion 0) 100 + Right decoded <- pure (traverse (decodeRecorded workflowJournalCodec) (Vector.toList recorded)) + any (\case WorkflowCompleted {} -> True; _ -> False) decoded `shouldBe` False + + it "re-appends a missing journal entry when re-signalled (crash-safe)" $ \storeHandle -> do + aidRef <- newIORef Nothing + let name = WorkflowName "crash" + wid = WorkflowId "wf3" + Right Suspended <- Store.runStoreIO storeHandle $ runWorkflow name wid (approvalFlowWithId aidRef) + aid <- readRequiredAwakeableId aidRef + let awkStep = "awk:" <> awakeableIdText aid + -- Simulate "row completed but the journal append did not happen" by + -- completing the row directly, bypassing signalAwakeable's journal write. + now <- getCurrentTime + Right completedRow <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + Awk.completeAwakeableTx (awakeableIdToUuid aid) (toJSON ("ok" :: Text)) now + completedRow `shouldBe` True + Right beforeRepair <- + Store.runStoreIO storeHandle $ + Store.readStreamForward (StreamName "wf:crash-wf3") (StreamVersion 0) 100 + Right beforeDecoded <- pure (traverse (decodeRecorded workflowJournalCodec) (Vector.toList beforeRepair)) + [() | StepRecorded s _ _ <- beforeDecoded, s == awkStep] `shouldBe` [] + -- A re-signal with the same payload returns False (already completed) but + -- repairs the missing journal entry from the stored payload. + Right repaired <- Store.runStoreIO storeHandle $ signalAwakeable aid ("ok" :: Text) + repaired `shouldBe` False + Right afterRepair <- + Store.runStoreIO storeHandle $ + Store.readStreamForward (StreamName "wf:crash-wf3") (StreamVersion 0) 100 + Right afterDecoded <- pure (traverse (decodeRecorded workflowJournalCodec) (Vector.toList afterRepair)) + [r | StepRecorded s r _ <- afterDecoded, s == awkStep] `shouldBe` [toJSON ("ok" :: Text)] + + it "repairs a completed awakeable row from the await arm without a second signal" $ \storeHandle -> do + aidRef <- newIORef Nothing + let name = WorkflowName "crash-arm" + wid = WorkflowId "wf4" + Right Suspended <- Store.runStoreIO storeHandle $ runWorkflow name wid (approvalFlowWithId aidRef) + aid <- readRequiredAwakeableId aidRef + let awkStep = "awk:" <> awakeableIdText aid + now <- getCurrentTime + Right True <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + Awk.completeAwakeableTx (awakeableIdToUuid aid) (toJSON ("ok" :: Text)) now + repairedRun <- Store.runStoreIO storeHandle $ runWorkflow name wid (approvalFlowWithId aidRef) + repairedRun `shouldBe` Right Suspended + Right repairedJournal <- + Store.runStoreIO storeHandle $ + Store.readStreamForward (StreamName "wf:crash-arm-wf4") (StreamVersion 0) 100 + Right repairedDecoded <- pure (traverse (decodeRecorded workflowJournalCodec) (Vector.toList repairedJournal)) + [r | StepRecorded s r _ <- repairedDecoded, s == awkStep] `shouldBe` [toJSON ("ok" :: Text)] + completed <- Store.runStoreIO storeHandle $ runWorkflow name wid (approvalFlowWithId aidRef) + completed `shouldBe` Right (Completed "ok!") + + it "refuses a forged coordinate-derived id for a fresh awakeable" $ \storeHandle -> do + aidRef <- newIORef Nothing + let name = WorkflowName "fresh-awake" + wid = WorkflowId "fa-1" + forged = deterministicAwakeableId name wid "approval" + Right Suspended <- Store.runStoreIO storeHandle $ runWorkflow name wid (approvalFlowWithId aidRef) + real <- readRequiredAwakeableId aidRef + real `shouldNotBe` forged + Right forgedSignal <- Store.runStoreIO storeHandle $ signalAwakeable forged ("bad" :: Text) + forgedSignal `shouldBe` False + Right stillSuspended <- Store.runStoreIO storeHandle $ runWorkflow name wid (approvalFlowWithId aidRef) + stillSuspended `shouldBe` Suspended + Right realSignal <- Store.runStoreIO storeHandle $ signalAwakeable real ("ok" :: Text) + realSignal `shouldBe` True + completed <- Store.runStoreIO storeHandle $ runWorkflow name wid (approvalFlowWithId aidRef) + completed `shouldBe` Right (Completed "ok!") + + it "adopts a generation-0 legacy deterministic row" $ \storeHandle -> do + aidRef <- newIORef Nothing + let name = WorkflowName "legacy-awake" + wid = WorkflowId "la-1" + legacy = deterministicAwakeableId name wid "approval" + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + Awk.registerAwakeableTx (awakeableIdToUuid legacy) (unWorkflowName name) (unWorkflowId wid) + Right Suspended <- Store.runStoreIO storeHandle $ runWorkflow name wid (approvalFlowWithId aidRef) + adopted <- readRequiredAwakeableId aidRef + adopted `shouldBe` legacy + Right True <- Store.runStoreIO storeHandle $ signalAwakeable legacy ("ok" :: Text) + completed <- Store.runStoreIO storeHandle $ runWorkflow name wid (approvalFlowWithId aidRef) + completed `shouldBe` Right (Completed "ok!") + + it "allocates a fresh awakeable for the same label after continueAsNew" $ \storeHandle -> do + idsRef <- newIORef [] + let name = WorkflowName "awake-roll" + wid = WorkflowId "ar-1" + body = rollingAwakeableWorkflow idsRef + Right Suspended <- Store.runStoreIO storeHandle $ runWorkflow name wid body + ids1 <- readIORef idsRef + [firstAid] <- pure ids1 + Right True <- Store.runStoreIO storeHandle $ signalAwakeable firstAid ("first" :: Text) + Right ContinuedAsNew <- Store.runStoreIO storeHandle $ runWorkflow name wid body + Right Suspended <- Store.runStoreIO storeHandle $ runWorkflow name wid body + ids2 <- readIORef idsRef + case ids2 of + [firstAgain, secondAid] -> do + firstAgain `shouldBe` firstAid + secondAid `shouldNotBe` firstAid + Right staleSignal <- Store.runStoreIO storeHandle $ signalAwakeable firstAid ("stale" :: Text) + staleSignal `shouldBe` False + Right stillSuspended <- Store.runStoreIO storeHandle $ runWorkflow name wid body + stillSuspended `shouldBe` Suspended + Right True <- Store.runStoreIO storeHandle $ signalAwakeable secondAid ("second" :: Text) + completed <- Store.runStoreIO storeHandle $ runWorkflow name wid body + completed `shouldBe` Right (Completed "second") + other -> expectationFailure ("expected two awakeable ids, got " <> show other) + + describe "Keiro.Workflow awakeable registration" $ around (withFreshStore fixture) $ do + it "registers the row before a journaled hand-off can expose the id" $ \storeHandle -> do + aidRef <- newIORef Nothing + let name = WorkflowName "awakeable-signal-gap" + wid = WorkflowId "asg-1" + Right Suspended <- + Store.runStoreIO storeHandle $ + runWorkflow name wid (publishAwakeableBeforeAwait aidRef) + aid <- readRequiredAwakeableId aidRef + Right (Just pendingRow) <- + Store.runStoreIO storeHandle $ + Awk.lookupAwakeable (awakeableIdToUuid aid) + pendingRow ^. #status `shouldBe` Awk.Pending + + Right signalled <- + Store.runStoreIO storeHandle $ + signalAwakeable aid ("ok" :: Text) + signalled `shouldBe` True + Right (Just completedRow) <- + Store.runStoreIO storeHandle $ + Awk.lookupAwakeable (awakeableIdToUuid aid) + completedRow ^. #status `shouldBe` Awk.Completed + + let unknown = + AwakeableId + (uuidLiteral "00000000-0000-0000-0000-0000000002f2") + Right unknownSignal <- + Store.runStoreIO storeHandle $ + signalAwakeable unknown ("forged" :: Text) + unknownSignal `shouldBe` False + + completed <- + Store.runStoreIO storeHandle $ + runWorkflow name wid (awaitPublishedAwakeable aidRef) + completed `shouldBe` Right (Completed "ok") + + describe "Keiro.Workflow awakeable signal race" $ around (withFreshStore fixture) $ do + it "does not append a value when cancellation wins after the signal pre-read" $ \storeHandle -> do + aidRef <- newIORef Nothing + let name = WorkflowName "awakeable-cancel-race" + wid = WorkflowId "acr-1" + Right Suspended <- + Store.runStoreIO storeHandle $ + runWorkflow name wid (approvalFlowWithId aidRef) + aid <- readRequiredAwakeableId aidRef + Right (Just stalePendingRow) <- + Store.runStoreIO storeHandle $ + Awk.lookupAwakeable (awakeableIdToUuid aid) + Right cancelled <- Store.runStoreIO storeHandle $ cancelAwakeable aid + cancelled `shouldBe` True + Right signalled <- + Store.runStoreIO storeHandle $ + signalAwakeableFrom stalePendingRow ("late" :: Text) + signalled `shouldBe` False + Right recorded <- + Store.runStoreIO storeHandle $ + stepExists + name + wid + 0 + (awakeableStepPrefix <> awakeableIdText aid) + recorded `shouldBe` False + Store.runStoreIO storeHandle (runWorkflow name wid (approvalFlowWithId aidRef)) + `shouldThrow` (== WorkflowAwakeableCancelled aid) + + describe "Keiro.Workflow.Child" $ do + -- M2: the reserved spawn/result step-name derivations are stable. + it "derives the child spawn and result step names" $ do + childSpawnStepName (WorkflowId "c1") `shouldBe` "child:c1" + childResultStepName (WorkflowId "c1") `shouldBe` "child:c1:result" + + -- M3(a): the new terminal journal constructors round-trip through the codec. + it "round-trips WorkflowCancelled and WorkflowFailed through the journal codec" $ do + let t = UTCTime (ModifiedJulianDay 0) 0 + rt ev = (workflowJournalCodec ^. #decode) ((workflowJournalCodec ^. #eventType) ev) ((workflowJournalCodec ^. #encode) ev) + rt (WorkflowCancelled t) `shouldBe` Right (WorkflowCancelled t) + rt (WorkflowFailed "boom" t) `shouldBe` Right (WorkflowFailed "boom" t) + + around (withFreshStore fixture) $ do + -- M1: the keiro_workflow_children table and its schema helpers. + it "schema: registers, completes, cancels, and counts child links" $ \storeHandle -> do + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + Child.registerChildTx "c-1" "ship" "p-1" "parent" "child:c-1:result" + Right (Just row) <- Store.runStoreIO storeHandle $ Child.lookupChild "c-1" "ship" + row ^. #status `shouldBe` Child.Running + row ^. #parentId `shouldBe` "p-1" + row ^. #parentName `shouldBe` "parent" + row ^. #awaitStep `shouldBe` "child:c-1:result" + now <- getCurrentTime + Right firstComplete <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + Child.markChildResultTx "c-1" "ship" (toJSON ("packed+labelled" :: Text)) now + firstComplete `shouldBe` True + Right secondComplete <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + Child.markChildResultTx "c-1" "ship" (toJSON ("again" :: Text)) now + secondComplete `shouldBe` False + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + Child.registerChildTx "c-2" "ship" "p-1" "parent" "child:c-2:result" + Right cancelled <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + Child.markChildCancelledTx "c-2" "ship" + cancelled `shouldBe` True + Right kids <- Store.runStoreIO storeHandle $ Child.lookupChildrenOfParent "p-1" "parent" + map (^. #childId) kids `shouldBe` ["c-1", "c-2"] + Right active <- Store.runStoreIO storeHandle Child.countActiveChildren + active `shouldBe` (0 :: Int) + Right st <- Store.runStoreIO storeHandle $ Child.childStatus "c-1" "ship" + st `shouldBe` Just Child.ChildCompleted + + -- M4: spawn -> drive the child (with the completion hook) -> resume parent. + it "spawns a child, drives it, propagates its result, and resumes the parent to Completed" $ \storeHandle -> do + let childWid = WorkflowId "ship-1" + suspended <- + Store.runStoreIO storeHandle $ + runWorkflow (WorkflowName "parent") (WorkflowId "p1") (parentWorkflow childWid) + suspended `shouldBe` Right Suspended + Right parentJournal1 <- + Store.runStoreIO storeHandle $ + Store.readStreamForward (StreamName "wf:parent-p1") (StreamVersion 0) 10 + Right decoded1 <- pure (traverse (decodeRecorded workflowJournalCodec) (Vector.toList parentJournal1)) + decoded1 `shouldSatisfy` \case + [StepRecorded "child:ship-1" _ _] -> True + _ -> False + Right (Just childRow) <- Store.runStoreIO storeHandle $ Child.lookupChild "ship-1" "ship" + childRow ^. #status `shouldBe` Child.Running + childRow ^. #parentId `shouldBe` "p1" + childRow ^. #parentName `shouldBe` "parent" + childRow ^. #awaitStep `shouldBe` "child:ship-1:result" + -- 2) drive the child through runChildWorkflow (propagates on completion). + childOutcome <- + Store.runStoreIO storeHandle $ + runChildWorkflow defaultWorkflowRunOptions (WorkflowName "ship") childWid shipWorkflow + childOutcome `shouldBe` Right (Completed "packed+labelled") + Right childJournal <- + Store.runStoreIO storeHandle $ + Store.readStreamForward (StreamName "wf:ship-ship-1") (StreamVersion 0) 10 + traverse (decodeRecorded workflowJournalCodec) (Vector.toList childJournal) + `shouldSatisfy` \case + Right [StepRecorded "pack" _ _, StepRecorded "label" _ _, WorkflowCompleted _] -> True + _ -> False + Right parentJournal2 <- + Store.runStoreIO storeHandle $ + Store.readStreamForward (StreamName "wf:parent-p1") (StreamVersion 0) 10 + Right decoded2 <- pure (traverse (decodeRecorded workflowJournalCodec) (Vector.toList parentJournal2)) + [r | StepRecorded "child:ship-1:result" r _ <- decoded2] + `shouldBe` [object ["ok" Aeson..= ("packed+labelled" :: Text)]] + Right (Just childRow2) <- Store.runStoreIO storeHandle $ Child.lookupChild "ship-1" "ship" + childRow2 ^. #status `shouldBe` Child.ChildCompleted + -- 3) resume the parent: it replays past awaitChild and completes. + resumed <- + Store.runStoreIO storeHandle $ + runWorkflow (WorkflowName "parent") (WorkflowId "p1") (parentWorkflow childWid) + resumed `shouldBe` Right (Completed "done:packed+labelled") + Right parentJournal3 <- + Store.runStoreIO storeHandle $ + Store.readStreamForward (StreamName "wf:parent-p1") (StreamVersion 0) 10 + Right decoded3 <- pure (traverse (decodeRecorded workflowJournalCodec) (Vector.toList parentJournal3)) + any (\case StepRecorded "notify" _ _ -> True; _ -> False) decoded3 `shouldBe` True + any (\case WorkflowCompleted {} -> True; _ -> False) decoded3 `shouldBe` True + + it "repairs a completed child row from awaitChild without another completion hook" $ \storeHandle -> do + let childWid = WorkflowId "ship-crash" + Right Suspended <- + Store.runStoreIO storeHandle $ + runWorkflow (WorkflowName "parent") (WorkflowId "p-crash") (parentWorkflow childWid) + now <- getCurrentTime + Right transitioned <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + Child.markChildResultTx "ship-crash" "ship" (toJSON ("packed+labelled" :: Text)) now + transitioned `shouldBe` True + Right beforeRepair <- + Store.runStoreIO storeHandle $ + Store.readStreamForward (StreamName "wf:parent-p-crash") (StreamVersion 0) 10 + Right beforeDecoded <- pure (traverse (decodeRecorded workflowJournalCodec) (Vector.toList beforeRepair)) + [r | StepRecorded "child:ship-crash:result" r _ <- beforeDecoded] `shouldBe` [] + repaired <- + Store.runStoreIO storeHandle $ + runWorkflow (WorkflowName "parent") (WorkflowId "p-crash") (parentWorkflow childWid) + repaired `shouldBe` Right Suspended + Right afterRepair <- + Store.runStoreIO storeHandle $ + Store.readStreamForward (StreamName "wf:parent-p-crash") (StreamVersion 0) 10 + Right afterDecoded <- pure (traverse (decodeRecorded workflowJournalCodec) (Vector.toList afterRepair)) + [r | StepRecorded "child:ship-crash:result" r _ <- afterDecoded] + `shouldBe` [object ["ok" Aeson..= ("packed+labelled" :: Text)]] + completed <- + Store.runStoreIO storeHandle $ + runWorkflow (WorkflowName "parent") (WorkflowId "p-crash") (parentWorkflow childWid) + completed `shouldBe` Right (Completed "done:packed+labelled") + + -- M5: re-invoking the parent does not re-spawn the child (crash survival). + it "does not re-spawn the child when the parent is re-invoked" $ \storeHandle -> do + let childWid = WorkflowId "ship-2" + s1 <- + Store.runStoreIO storeHandle $ + runWorkflow (WorkflowName "parent") (WorkflowId "p2") (parentWorkflow childWid) + s1 `shouldBe` Right Suspended + Right (Just beforeRow) <- Store.runStoreIO storeHandle $ Child.lookupChild "ship-2" "ship" + let createdAt0 = beforeRow ^. #createdAt + s2 <- + Store.runStoreIO storeHandle $ + runWorkflow (WorkflowName "parent") (WorkflowId "p2") (parentWorkflow childWid) + s2 `shouldBe` Right Suspended + Right parentJournal <- + Store.runStoreIO storeHandle $ + Store.readStreamForward (StreamName "wf:parent-p2") (StreamVersion 0) 10 + Right decoded <- pure (traverse (decodeRecorded workflowJournalCodec) (Vector.toList parentJournal)) + length [() | StepRecorded "child:ship-2" _ _ <- decoded] `shouldBe` 1 + Right kids <- Store.runStoreIO storeHandle $ Child.lookupChildrenOfParent "p2" "parent" + length kids `shouldBe` 1 + map (^. #createdAt) kids `shouldBe` [createdAt0] + + -- M5: cancelling a child stops it and makes the parent's awaitChild throw. + it "cancels a child: the child stops and the parent's awaitChild throws" $ \storeHandle -> do + let childWid = WorkflowId "cancel-child" + h = ChildHandle (WorkflowName "ship") childWid + s1 <- + Store.runStoreIO storeHandle $ + runWorkflow (WorkflowName "parent") (WorkflowId "p3") (parentWorkflow childWid) + s1 `shouldBe` Right Suspended + Right cancelled <- Store.runStoreIO storeHandle $ cancelChild h + cancelled `shouldBe` True + Right childJournal <- + Store.runStoreIO storeHandle $ + Store.readStreamForward (StreamName "wf:ship-cancel-child") (StreamVersion 0) 10 + Right childDecoded <- pure (traverse (decodeRecorded workflowJournalCodec) (Vector.toList childJournal)) + any (\case WorkflowCancelled {} -> True; _ -> False) childDecoded `shouldBe` True + Right st <- Store.runStoreIO storeHandle $ Child.childStatus "cancel-child" "ship" + st `shouldBe` Just Child.ChildCancelled + Right parentJournal <- + Store.runStoreIO storeHandle $ + Store.readStreamForward (StreamName "wf:parent-p3") (StreamVersion 0) 10 + Right parentDecoded <- pure (traverse (decodeRecorded workflowJournalCodec) (Vector.toList parentJournal)) + [r | StepRecorded "child:cancel-child:result" r _ <- parentDecoded] + `shouldBe` [object ["cancelled" Aeson..= True]] + -- driving the child returns Cancelled and runs none of its steps. + childOutcome <- + Store.runStoreIO storeHandle $ + runWorkflow (WorkflowName "ship") childWid shipWorkflow + childOutcome `shouldBe` Right Keiro.Workflow.Cancelled + Right childJournal2 <- + Store.runStoreIO storeHandle $ + Store.readStreamForward (StreamName "wf:ship-cancel-child") (StreamVersion 0) 10 + Right childDecoded2 <- pure (traverse (decodeRecorded workflowJournalCodec) (Vector.toList childJournal2)) + any (\case StepRecorded "pack" _ _ -> True; _ -> False) childDecoded2 `shouldBe` False + -- re-invoking the parent throws WorkflowChildCancelled. + Store.runStoreIO + storeHandle + (runWorkflow (WorkflowName "parent") (WorkflowId "p3") (parentWorkflow childWid)) + `shouldThrow` (== WorkflowChildCancelled (WorkflowName "ship") childWid) + + it "repairs a cancelled child row when cancelChild is retried after the row flip" $ \storeHandle -> do + let childWid = WorkflowId "cancel-child-crash" + h = ChildHandle (WorkflowName "ship") childWid + Right Suspended <- + Store.runStoreIO storeHandle $ + runWorkflow (WorkflowName "parent") (WorkflowId "p-cancel-crash") (parentWorkflow childWid) + Right transitioned <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + Child.markChildCancelledTx "cancel-child-crash" "ship" + transitioned `shouldBe` True + Right retried <- Store.runStoreIO storeHandle $ cancelChild h + retried `shouldBe` False + Right childJournal <- + Store.runStoreIO storeHandle $ + Store.readStreamForward (StreamName "wf:ship-cancel-child-crash") (StreamVersion 0) 10 + Right childDecoded <- pure (traverse (decodeRecorded workflowJournalCodec) (Vector.toList childJournal)) + any (\case WorkflowCancelled {} -> True; _ -> False) childDecoded `shouldBe` True + Right parentJournal <- + Store.runStoreIO storeHandle $ + Store.readStreamForward (StreamName "wf:parent-p-cancel-crash") (StreamVersion 0) 10 + Right parentDecoded <- pure (traverse (decodeRecorded workflowJournalCodec) (Vector.toList parentJournal)) + [r | StepRecorded "child:cancel-child-crash:result" r _ <- parentDecoded] + `shouldBe` [object ["cancelled" Aeson..= True]] + + it "heals a cancelled-but-unmarked child from runChildWorkflow" $ \storeHandle -> do + let childWid = WorkflowId "cancel-child-drive" + Right Suspended <- + Store.runStoreIO storeHandle $ + runWorkflow (WorkflowName "parent") (WorkflowId "p-cancel-drive") (parentWorkflow childWid) + Right True <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + Child.markChildCancelledTx "cancel-child-drive" "ship" + childOutcome <- + Store.runStoreIO storeHandle $ + runChildWorkflow defaultWorkflowRunOptions (WorkflowName "ship") childWid shipWorkflow + childOutcome `shouldBe` Right Keiro.Workflow.Cancelled + Right childJournal <- + Store.runStoreIO storeHandle $ + Store.readStreamForward (StreamName "wf:ship-cancel-child-drive") (StreamVersion 0) 10 + Right childDecoded <- pure (traverse (decodeRecorded workflowJournalCodec) (Vector.toList childJournal)) + any (\case WorkflowCancelled {} -> True; _ -> False) childDecoded `shouldBe` True + Right parentJournal <- + Store.runStoreIO storeHandle $ + Store.readStreamForward (StreamName "wf:parent-p-cancel-drive") (StreamVersion 0) 10 + Right parentDecoded <- pure (traverse (decodeRecorded workflowJournalCodec) (Vector.toList parentJournal)) + [r | StepRecorded "child:cancel-child-drive:result" r _ <- parentDecoded] + `shouldBe` [object ["cancelled" Aeson..= True]] + + it "delivers an honest child result equal to the old cancellation sentinel" $ \storeHandle -> do + let childWid = WorkflowId "json-cancelled-object" + Right Suspended <- + Store.runStoreIO storeHandle $ + runWorkflow (WorkflowName "json-parent") (WorkflowId "jp1") (jsonObjectParentWorkflow childWid) + childOutcome <- + Store.runStoreIO storeHandle $ + runChildWorkflow defaultWorkflowRunOptions (WorkflowName "json-child") childWid jsonObjectChildWorkflow + childOutcome `shouldBe` Right (Completed (object ["cancelled" Aeson..= True])) + completed <- + Store.runStoreIO storeHandle $ + runWorkflow (WorkflowName "json-parent") (WorkflowId "jp1") (jsonObjectParentWorkflow childWid) + completed `shouldBe` Right (Completed (object ["cancelled" Aeson..= True])) + Right parentJournal <- + Store.runStoreIO storeHandle $ + Store.readStreamForward (StreamName "wf:json-parent-jp1") (StreamVersion 0) 10 + Right parentDecoded <- pure (traverse (decodeRecorded workflowJournalCodec) (Vector.toList parentJournal)) + [r | StepRecorded "child:json-cancelled-object:result" r _ <- parentDecoded] + `shouldBe` [object ["ok" Aeson..= object ["cancelled" Aeson..= True]]] + + it "throws WorkflowStepDecodeError when an enveloped child result has the wrong type" $ \storeHandle -> do + let childWid = WorkflowId "decode-child" + Right Suspended <- + Store.runStoreIO storeHandle $ + runWorkflow (WorkflowName "parent") (WorkflowId "p-decode") (parentWorkflow childWid) + Store.runStoreIO + storeHandle + (childCompletionHook (WorkflowName "ship") childWid (toJSON (42 :: Int))) + `shouldReturn` Right () + Store.runStoreIO + storeHandle + (runWorkflow (WorkflowName "parent") (WorkflowId "p-decode") (parentWorkflow childWid)) + `shouldThrow` \case + WorkflowStepDecodeError key _ -> key == "child:decode-child:result" + _ -> False + + it "wakes a parent with WorkflowChildFailed when a child reaches the failure ceiling" $ \storeHandle -> do + let childWid = WorkflowId "failed-child" + registry = + Map.fromList + [ (WorkflowName "parent", WorkflowDef (\_ -> parentWorkflow childWid)), + (WorkflowName "ship", WorkflowDef (\_ -> liftIO (throwIO SimulatedCrash) *> pure ("" :: Text))) + ] + opts = defaultWorkflowResumeOptions & #maxAttempts .~ 1 + Right Suspended <- + Store.runStoreIO storeHandle $ + runWorkflow (WorkflowName "parent") (WorkflowId "p-failed-child") (parentWorkflow childWid) + Right summary <- Store.runStoreIO storeHandle $ resumeWorkflowsOnce opts registry + failed summary `shouldBe` 1 + Right (Just childRow) <- Store.runStoreIO storeHandle $ Child.lookupChild "failed-child" "ship" + childRow ^. #status `shouldBe` Child.ChildFailed + Store.runStoreIO + storeHandle + (runWorkflow (WorkflowName "parent") (WorkflowId "p-failed-child") (parentWorkflow childWid)) + `shouldThrow` \case + WorkflowChildFailed (WorkflowName "ship") (WorkflowId "failed-child") reason -> + "SimulatedCrash" `Text.isInfixOf` reason + _ -> False + + it "stops at the next step boundary when a workflow is cancelled mid-run" $ \storeHandle -> do + counter <- newIORef 0 + let name = WorkflowName "self-cancel" + wid = WorkflowId "sc1" + outcome <- + Store.runStoreIO storeHandle $ + runWorkflow name wid (selfCancellingWorkflow name wid counter) + outcome `shouldBe` Right Keiro.Workflow.Cancelled + readIORef counter `shouldReturn` 2 + Right recorded <- + Store.runStoreIO storeHandle $ + Store.readStreamForward (StreamName "wf:self-cancel-sc1") (StreamVersion 0) 10 + Right decoded <- pure (traverse (decodeRecorded workflowJournalCodec) (Vector.toList recorded)) + any (\case StepRecorded "three" _ _ -> True; _ -> False) decoded `shouldBe` False + + -- EP-42 worker-driven variant: the resume worker drives both parent and + -- child from a registry, selecting childCompletionHook for the child and + -- union-discovering the zero-step child. + it "drives a parent and its child to completion through the resume worker" $ \storeHandle -> do + let childWid = WorkflowId "ship-3" + registry = + Map.fromList + [ (WorkflowName "parent", WorkflowDef (\_ -> parentWorkflow childWid)), + (WorkflowName "ship", WorkflowDef (\_ -> shipWorkflow)) + ] + Right Suspended <- + Store.runStoreIO storeHandle $ + runWorkflow (WorkflowName "parent") (WorkflowId "p4") (parentWorkflow childWid) + let drive = Store.runStoreIO storeHandle (resumeWorkflowsOnce defaultWorkflowResumeOptions registry) + Right _ <- drive + Right _ <- drive + Right _ <- drive + Right parentJournal <- + Store.runStoreIO storeHandle $ + Store.readStreamForward (StreamName "wf:parent-p4") (StreamVersion 0) 10 + Right parentDecoded <- pure (traverse (decodeRecorded workflowJournalCodec) (Vector.toList parentJournal)) + any (\case WorkflowCompleted {} -> True; _ -> False) parentDecoded `shouldBe` True + Right (Just childRow) <- Store.runStoreIO storeHandle $ Child.lookupChild "ship-3" "ship" + childRow ^. #status `shouldBe` Child.ChildCompleted + + it "attaches to a completed child after continueAsNew" $ \storeHandle -> do + let childWid = WorkflowId "ship-rotated" + parentName = WorkflowName "parent-rotating" + parentId = WorkflowId "p-rotating" + body = rotatingParentWorkflow childWid + Right Suspended <- Store.runStoreIO storeHandle $ runWorkflow parentName parentId body + childOutcome <- + Store.runStoreIO storeHandle $ + runChildWorkflow defaultWorkflowRunOptions (WorkflowName "ship") childWid shipWorkflow + childOutcome `shouldBe` Right (Completed "packed+labelled") + Right ContinuedAsNew <- Store.runStoreIO storeHandle $ runWorkflow parentName parentId body + repair <- Store.runStoreIO storeHandle $ runWorkflow parentName parentId body + repair `shouldBe` Right Suspended + completed <- Store.runStoreIO storeHandle $ runWorkflow parentName parentId body + completed `shouldBe` Right (Completed "packed+labelled") + + describe "Keiro.Workflow.Child durable failed delivery" $ around (withFreshStore fixture) $ do + it "delivers a persisted child failure after the parent rotates past the failure journal" $ \storeHandle -> do + let childWid = WorkflowId "failed-before-rotation" + parentName = WorkflowName "parent-failure-rotation" + parentId = WorkflowId "p-failure-rotation" + registry = + Map.fromList + [ (parentName, WorkflowDef (\_ -> failedChildBeforeRotation childWid)), + (WorkflowName "ship", WorkflowDef (\_ -> liftIO (throwIO SimulatedCrash) *> pure ("" :: Text))) + ] + opts = defaultWorkflowResumeOptions & #maxAttempts .~ 1 + Right Suspended <- + Store.runStoreIO storeHandle $ + runWorkflow parentName parentId (failedChildBeforeRotation childWid) + Right summary <- Store.runStoreIO storeHandle $ resumeWorkflowsOnce opts registry + failed summary `shouldBe` 1 + Right (Just childRow) <- + Store.runStoreIO storeHandle $ + Child.lookupChild "failed-before-rotation" "ship" + childRow ^. #status `shouldBe` Child.ChildFailed + childRow ^. #failureReason + `shouldSatisfy` maybe False ("SimulatedCrash" `Text.isInfixOf`) + Right failedOnGenerationZero <- + Store.runStoreIO storeHandle $ + stepExists + parentName + parentId + 0 + (childResultStepName childWid) + failedOnGenerationZero `shouldBe` True + + Right ContinuedAsNew <- + Store.runStoreIO storeHandle $ + runWorkflow parentName parentId (rotatePastFailedChild childWid) + Right generation <- Store.runStoreIO storeHandle $ currentGeneration parentName parentId + generation `shouldBe` 1 + Right failedOnGenerationOne <- + Store.runStoreIO storeHandle $ + stepExists + parentName + parentId + 1 + (childResultStepName childWid) + failedOnGenerationOne `shouldBe` False + + delivered <- + Store.runStoreIO storeHandle $ + runWorkflow parentName parentId (catchFailedChildAfterRotation childWid) + delivered `shouldSatisfy` \case + Right (Completed reason) -> "SimulatedCrash" `Text.isInfixOf` reason + _ -> False + + describe "Keiro.Workflow.Gc" $ around (withFreshStore fixture) $ do + it "deletes terminal workflow data after retention" $ \storeHandle -> do + let name = WorkflowName "gc-basic" + wid = WorkflowId "gb-1" + gcStreamName = workflowGenerationStreamName name wid 0 + aid = fromMaybe (error "invalid gc awakeable uuid") (fromString "00000000-0000-0000-0000-0000000000a1") + timerId = fromMaybe (error "invalid gc timer uuid") (fromString "00000000-0000-0000-0000-0000000000a2") + counter <- newIORef (0 :: Int) + Right (Completed _) <- + Store.runStoreIO storeHandle $ + runWorkflowWith + (defaultWorkflowRunOptions & #snapshotPolicy .~ OnTerminal) + name + wid + (demoWorkflow counter) + now <- getCurrentTime + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ do + Awk.registerAwakeableTx aid "gc-basic" "gb-1" + Tx.statement (timerId, "gc-basic", "gb-1", now, object ["kind" Aeson..= ("keiro.workflow.sleep" :: Text)], "fired") insertGcTimerStmt + Right beforeCounts <- Store.runStoreIO storeHandle $ workflowOwnedRowCounts "gc-basic" "gb-1" + beforeCounts `shouldBe` (1, 3, 1, 0, 1, 1) + Right freshSummary <- + Store.runStoreIO storeHandle $ + WorkflowGc.gcWorkflowsOnce + now + WorkflowGc.WorkflowGcPolicy {retention = 3600, batchSize = 10} + freshSummary `shouldBe` WorkflowGc.WorkflowGcSummary {scanned = 0, deleted = 0} + Right (Just _) <- Store.runStoreIO storeHandle $ Store.lookupStreamId gcStreamName + Right deletedSummary <- + Store.runStoreIO storeHandle $ + WorkflowGc.gcWorkflowsOnce + (addUTCTime 1 now) + WorkflowGc.WorkflowGcPolicy {retention = 0, batchSize = 10} + deletedSummary `shouldBe` WorkflowGc.WorkflowGcSummary {scanned = 1, deleted = 1} + Right Nothing <- Store.runStoreIO storeHandle $ Store.lookupStreamId gcStreamName + Right afterCounts <- Store.runStoreIO storeHandle $ workflowOwnedRowCounts "gc-basic" "gb-1" + afterCounts `shouldBe` (0, 0, 0, 0, 0, 0) + + it "deletes scheduled sleep timers so a collected workflow cannot resurrect" $ \storeHandle -> do + counter <- newIORef (0 :: Int) + let name = WorkflowName "gc-scheduled-sleep" + wid = WorkflowId "gss-1" + journalStream = workflowGenerationStreamName name wid 0 + TimerId timerUuid = sleepTimerId name wid 0 "sleep:wait" + body = do + _ <- step (StepName "before-sleep") (liftIO (incrementAndRead counter)) + sleepNamed (StepName "wait") 3600 + Right Suspended <- + Store.runStoreIO storeHandle $ + runWorkflow name wid body + Right timerBeforeGc <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + Tx.statement timerUuid sleepTimerStatusStmt + fmap fst timerBeforeGc `shouldBe` Just "scheduled" + + cancelledAt <- getCurrentTime + Right () <- + Store.runStoreIO storeHandle $ + appendJournalEntry name wid (WorkflowCancelled cancelledAt) + gcClock <- getCurrentTime + Right collected <- + Store.runStoreIO storeHandle $ + WorkflowGc.gcWorkflowsOnce + (addUTCTime 1 gcClock) + WorkflowGc.WorkflowGcPolicy {retention = 0, batchSize = 10} + collected `shouldBe` WorkflowGc.WorkflowGcSummary {scanned = 1, deleted = 1} + + Right Nothing <- Store.runStoreIO storeHandle $ Instance.lookupInstance name wid + Right Nothing <- Store.runStoreIO storeHandle $ Store.lookupStreamId journalStream + Right timerAfterGc <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + Tx.statement timerUuid sleepTimerStatusStmt + timerAfterGc `shouldBe` Nothing + + Right noClaim <- + Store.runStoreIO storeHandle $ + runWorkflowTimerWorker Nothing (addUTCTime 7200 gcClock) (\_ -> pure Nothing) + noClaim `shouldBe` Nothing + Right Nothing <- Store.runStoreIO storeHandle $ Instance.lookupInstance name wid + Right Nothing <- Store.runStoreIO storeHandle $ Store.lookupStreamId journalStream + readIORef counter >>= (`shouldBe` 1) + + it "cancels a sleep fire when a terminal instance survives partial GC" $ \storeHandle -> do + let name = WorkflowName "gc-terminal-fire" + wid = WorkflowId "gtf-1" + full = "sleep:wait" + timerId@(TimerId timerUuid) = sleepTimerId name wid 0 full + journalStream = workflowGenerationStreamName name wid 0 + now <- getCurrentTime + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ do + Instance.upsertInstanceTx "gtf-1" "gc-terminal-fire" 0 Instance.WfCancelled Nothing + void $ + scheduleTimerOnceTx + TimerRequest + { timerId, + processManagerName = "gc-terminal-fire", + correlationId = "gtf-1", + fireAt = now, + payload = sleepTimerPayload 0 full + } + Right (Just claimed) <- + Store.runStoreIO storeHandle $ + runWorkflowTimerWorker Nothing now (\_ -> pure Nothing) + claimed ^. #timerId `shouldBe` timerId + Right terminalTimer <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + Tx.statement timerUuid sleepTimerStatusStmt + fmap fst terminalTimer `shouldBe` Just "cancelled" + Right Nothing <- Store.runStoreIO storeHandle $ Store.lookupStreamId journalStream + Right resolved <- + Store.runStoreIO storeHandle $ + stepExists name wid 0 full + resolved `shouldBe` False + + it "keeps completed children while a parent is live and converges after partial cleanup" $ \storeHandle -> do + let parentName = WorkflowName "gc-live-parent" + parentId = WorkflowId "gp-1" + childName = WorkflowName "gc-child" + childId = WorkflowId "gc-1" + now <- getCurrentTime + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ do + Instance.upsertInstanceTx "gp-1" "gc-live-parent" 0 Instance.WfRunning Nothing + Child.registerChildTx "gc-1" "gc-child" "gp-1" "gc-live-parent" "child:gc-1:result" + void (Child.markChildResultTx "gc-1" "gc-child" (toJSON ("ok" :: Text)) now) + Right () <- + Store.runStoreIO storeHandle $ + appendJournalEntry childName childId (WorkflowCompleted now) + Right held <- + Store.runStoreIO storeHandle $ + WorkflowGc.gcWorkflowsOnce + (addUTCTime 1 now) + WorkflowGc.WorkflowGcPolicy {retention = 0, batchSize = 10} + held `shouldBe` WorkflowGc.WorkflowGcSummary {scanned = 0, deleted = 0} + Right childStillThere <- Store.runStoreIO storeHandle $ Store.lookupStreamId (workflowGenerationStreamName childName childId 0) + childStillThere `shouldSatisfy` isJust + Right () <- + Store.runStoreIO storeHandle $ + appendJournalEntry parentName parentId (WorkflowCompleted now) + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + Tx.statement ("gc-1", "gc-child") deleteGcStepsStmt + Right collected <- + Store.runStoreIO storeHandle $ + WorkflowGc.gcWorkflowsOnce + (addUTCTime 1 now) + WorkflowGc.WorkflowGcPolicy {retention = 0, batchSize = 10} + collected `shouldBe` WorkflowGc.WorkflowGcSummary {scanned = 2, deleted = 2} + Right parentGone <- Store.runStoreIO storeHandle $ Instance.lookupInstance parentName parentId + parentGone `shouldBe` Nothing + Right childGone <- Store.runStoreIO storeHandle $ Instance.lookupInstance childName childId + childGone `shouldBe` Nothing + Right childRows <- Store.runStoreIO storeHandle $ workflowOwnedChildCount "gc-child" "gc-1" + childRows `shouldBe` 0 + +-- | Increment a shared counter and return its new value (the step's side +-- effect, so replay can be proven by watching the counter). +incrementAndRead :: IORef Int -> IO Int +incrementAndRead ref = atomicModifyIORef' ref (\n -> (n + 1, n + 1)) + +forceWorkflowLeaseStmt :: Statement (Text, Text, Text, UTCTime) () +forceWorkflowLeaseStmt = + preparable + """ + UPDATE keiro.keiro_workflows + SET leased_by = $3, + lease_expires_at = $4, + updated_at = now() + WHERE workflow_id = $1 + AND workflow_name = $2 + """ + ( contrazip4 + (E.param (E.nonNullable E.text)) + (E.param (E.nonNullable E.text)) + (E.param (E.nonNullable E.text)) + (E.param (E.nonNullable E.timestamptz)) + ) + D.noResult + +-- | Six numbered steps, each returning its index after bumping a shared +-- counter. The counter lets a re-hydration prove the steps short-circuit +-- (it stays at 6 when every step is replayed from the journal/snapshot). +countingSixSteps :: (Workflow :> es, IOE :> es) => IORef Int -> Eff es [Int] +countingSixSteps counter = + mapM + (\i -> step (StepName ("s" <> Text.pack (show i))) (liftIO (incrementAndRead counter) >> pure i)) + [1 .. 6] + +newtype Approx = Approx Double + deriving stock (Eq, Show) + +instance ToJSON Approx where + toJSON (Approx d) = toJSON (round d :: Int) + +instance FromJSON Approx where + parseJSON value = do + n <- Aeson.parseJSON value + pure (Approx (fromIntegral (n :: Int))) + +data RejectingRoundTrip = RejectingRoundTrip + deriving stock (Eq, Show) + +instance ToJSON RejectingRoundTrip where + toJSON RejectingRoundTrip = Aeson.String "not-an-object" + +instance FromJSON RejectingRoundTrip where + parseJSON = Aeson.withObject "RejectingRoundTrip" $ \_ -> pure RejectingRoundTrip + +-- | A distinguished exception used to simulate a process crash mid-workflow +-- (after a step has committed its journal append but before completion). +data SimulatedCrash = SimulatedCrash + deriving stock (Show) + +instance Exception SimulatedCrash + +-- | A three-step workflow; each step bumps a shared counter so a resume can +-- prove steps short-circuit (the counter only advances for steps that run). +threeStep :: (Workflow :> es, IOE :> es) => IORef Int -> Eff es (Int, Int, Int) +threeStep counter = do + a <- step (StepName "s1") (liftIO (incrementAndRead counter)) + b <- step (StepName "s2") (liftIO (incrementAndRead counter)) + c <- step (StepName "s3") (liftIO (incrementAndRead counter)) + pure (a, b, c) + +threeStepThenSignal :: (Workflow :> es, IOE :> es) => IORef Int -> MVar () -> Eff es (Int, Int, Int) +threeStepThenSignal counter done = do + result <- threeStep counter + liftIO (putMVar done ()) + pure result + +-- | Runs step @"s1"@ (which commits its own journal append) then crashes, so +-- the journal is left with one StepRecorded and no WorkflowCompleted. +crashAfterStep1 :: (Workflow :> es, IOE :> es) => IORef Int -> Eff es (Int, Int, Int) +crashAfterStep1 counter = do + _ <- step (StepName "s1") (liftIO (incrementAndRead counter)) + _ <- liftIO (throwIO SimulatedCrash) + pure (0, 0, 0) + +-- | A workflow with one durable side effect before a switchable failure and +-- one durable side effect after it. Resurrection tests use the counter to prove +-- the recorded prefix never executes again. +recoverableWorkflow :: + (Workflow :> es, IOE :> es) => + IORef Bool -> + IORef Int -> + Eff es Int +recoverableWorkflow shouldCrash counter = do + _ <- step (StepName "durable-prefix") (liftIO (incrementAndRead counter)) + crashing <- liftIO (readIORef shouldCrash) + when crashing (liftIO (throwIO SimulatedCrash)) + step (StepName "durable-tail") (liftIO (incrementAndRead counter)) + +-- | Awaits an external step, then runs a step that bumps the counter. Used to +-- prove the resume worker drives a suspended workflow to completion once its +-- awaited step is journaled. +awaitingThenStep :: (Workflow :> es, IOE :> es) => IORef Int -> Eff es Text +awaitingThenStep counter = do + decision <- awaitStep (StepName "awk:approval") (pure ()) + _ <- step (StepName "use") (liftIO (incrementAndRead counter) >> pure (decision <> "!")) + pure (decision <> "-done") + +-- | A rolling-total workflow (EP-48 continue-as-new acceptance). It adds @total@ +-- unit-valued work steps to a running total, rotating its journal every +-- @rotateEvery@ steps via 'continueAsNew'. The carried seed is the pair +-- @(runningTotal, stepsDoneGlobally)@ so each generation knows the global +-- progress; @genDone@ counts steps within the /current/ generation to bound it. +-- Each work step bumps @counter@ exactly once (proving rotation neither drops +-- nor double-counts) and returns 1, so the final total equals @total@. +-- +-- Step names are the global step index (@w0@, @w1@, …), so they are unique +-- within each generation's journal and replay-stable. Note the regression +-- direction: on a tree where 'continueAsNew' did not rotate, this body would put +-- all @total@ steps on generation 0's single journal and the per-generation +-- @<= K@ bound below would fail for @total > K@. +rollingTotal :: (Workflow :> es, IOE :> es) => IORef Int -> Int -> Int -> Eff es Int +rollingTotal counter rotateEvery total = do + (acc0, done0) <- restoreSeed (0 :: Int, 0 :: Int) + go acc0 done0 0 + where + go acc done genDone + | done >= total = pure acc -- all global work done: this generation completes + | genDone >= rotateEvery = continueAsNew (acc, done) -- bound this generation; carry onward + | otherwise = do + n <- + step + (StepName ("w" <> Text.pack (show done))) + (liftIO (modifyIORef' counter (+ 1) >> pure (1 :: Int))) + go (acc + n) (done + 1) (genDone + 1) + +-- The patch id under test (EP-49). +fraudPatchId :: PatchId +fraudPatchId = PatchId "fraud-check-v2" + +-- | The workflow BEFORE the patch shipped: reserve, then await an external step +-- (so an instance can be left in flight, mid-journal, with one ordinary step +-- recorded and no completion). Used to create the in-flight instance. +prePatchWorkflow :: (Workflow :> es, IOE :> es) => IORef Int -> Eff es Text +prePatchWorkflow counter = do + _ <- step (StepName "reserve-inventory") (liftIO (incrementAndRead counter) >> pure ()) + (_ :: ()) <- awaitStep (StepName "awk:gate") (pure ()) -- park here, in flight + pure "old-done" + +-- | The workflow AFTER the patch shipped: the same first step, then a +-- patch-gated cross-cutting branch. The in-flight instance (which already +-- journaled reserve-inventory under the pre-patch code) must observe False and +-- take the OLD branch; a fresh instance must observe True and take the NEW branch. +postPatchWorkflow :: (Workflow :> es, IOE :> es) => IORef Int -> Eff es Text +postPatchWorkflow counter = do + _ <- step (StepName "reserve-inventory") (liftIO (incrementAndRead counter) >> pure ()) + useNew <- patch fraudPatchId + if useNew + then step (StepName "new-charge") (pure "new-branch") + else step (StepName "old-charge") (pure "old-branch") + +postPatchAfterSuspendWorkflow :: (Workflow :> es, IOE :> es) => IORef Int -> Eff es Text +postPatchAfterSuspendWorkflow counter = do + _ <- step (StepName "reserve-inventory") (liftIO (incrementAndRead counter) >> pure ()) + (_ :: ()) <- awaitStep (StepName "awk:gate") (pure ()) + useNew <- patch fraudPatchId + if useNew + then step (StepName "new-charge") (pure "new-branch") + else step (StepName "old-charge") (pure "old-branch") + +prePatchWakeOnlyWorkflow :: (Workflow :> es) => Eff es Text +prePatchWakeOnlyWorkflow = do + (_ :: ()) <- awaitStep (StepName "awk:gate") (pure ()) + pure "old-done" + +postPatchWakeOnlyWorkflow :: (Workflow :> es) => Eff es Text +postPatchWakeOnlyWorkflow = do + (_ :: ()) <- awaitStep (StepName "awk:gate") (pure ()) + useNew <- patch fraudPatchId + if useNew + then step (StepName "new-charge") (pure "new-branch") + else step (StepName "old-charge") (pure "old-branch") + +rotatingPatchWorkflow :: (Workflow :> es) => Eff es Text +rotatingPatchWorkflow = do + seed <- restoreSeed (0 :: Int) + if seed < 1 + then continueAsNew (seed + 1) + else do + useNew <- patch fraudPatchId + if useNew + then step (StepName "new-charge") (pure "new-branch") + else step (StepName "old-charge") (pure "old-branch") + +-- | A workflow (EP-50 push tests) that awaits an external "awk:gate" step, then +-- runs a step that fills @done@ — so a test can observe the exact moment the +-- workflow resumes to completion. Awaiting first means the journal is empty until +-- the external gate append, which is what makes the instance discoverable by the +-- resume worker (the gate's StepRecorded is the first index row). +gateThenSignal :: (Workflow :> es, IOE :> es) => MVar () -> Eff es Text +gateThenSignal done = do + (_ :: ()) <- awaitStep (StepName "awk:gate") (pure ()) + _ <- step (StepName "after-gate") (liftIO (putMVar done ()) >> pure ()) + pure "resumed" + +-- | A two-step workflow whose steps each bump a shared counter. +demoWorkflow :: (Workflow :> es, IOE :> es) => IORef Int -> Eff es (Int, Int) +demoWorkflow counter = do + a <- step (StepName "first") (liftIO (incrementAndRead counter)) + b <- step (StepName "second") (liftIO (incrementAndRead counter)) + pure (a, b) + +-- | A workflow that immediately awaits a step nothing ever arms — used to +-- exercise the suspend path and external completion. +neverArmingWorkflow :: (Workflow :> es) => Eff es Int +neverArmingWorkflow = awaitStep (StepName "awk:test") (pure ()) + +-- | The awakeable validation workflow: allocate a durable promise, suspend on +-- it, and (once signalled) append "!" to the payload through a recorded step. +approvalFlowWithId :: (Workflow :> es, Store :> es, IOE :> es) => IORef (Maybe AwakeableId) -> Eff es Text +approvalFlowWithId ref = do + (aid, await) <- awakeableNamed (StepName "approval") + liftIO (writeIORef ref (Just aid)) + v <- await + step (StepName "use") (pure (v <> "!")) + +publishAwakeableBeforeAwait :: + forall es. + (Workflow :> es, Store :> es, IOE :> es) => + IORef (Maybe AwakeableId) -> + Eff es () +publishAwakeableBeforeAwait ref = do + (aid, _await :: Eff es Text) <- awakeableNamed (StepName "gate") + _ <- + step (StepName "publish") $ do + liftIO (writeIORef ref (Just aid)) + (_ :: ()) <- awaitStep (StepName "hold") (pure ()) + pure () + +awaitPublishedAwakeable :: + (Workflow :> es, Store :> es, IOE :> es) => + IORef (Maybe AwakeableId) -> + Eff es Text +awaitPublishedAwakeable ref = do + (aid, await) <- awakeableNamed (StepName "gate") + _ <- + step (StepName "publish") $ do + liftIO (writeIORef ref (Just aid)) + await + +snapshotUnsignalledAwakeable :: + (Workflow :> es, Store :> es, IOE :> es) => + IORef (Maybe AwakeableId) -> + Eff es Text +snapshotUnsignalledAwakeable ref = do + (aid, await) <- awakeableNamed (StepName "gate") + liftIO (writeIORef ref (Just aid)) + await + +snapshotShadowedAwakeable :: (Workflow :> es, Store :> es, IOE :> es) => Eff es Text +snapshotShadowedAwakeable = do + (aid, await) <- awakeableNamed (StepName "gate") + _ <- step (StepName "mid") (void (signalAwakeable aid ("payload" :: Text))) + await + +snapshotStaleAwakeablePhaseOne :: + forall es. + (Workflow :> es, Store :> es, IOE :> es) => + IORef (Maybe AwakeableId) -> + Eff es () +snapshotStaleAwakeablePhaseOne ref = do + (aid, _await :: Eff es Text) <- awakeableNamed (StepName "gate") + liftIO (writeIORef ref (Just aid)) + _ <- step (StepName "mid") (void (signalAwakeable aid ("payload" :: Text))) + (_ :: ()) <- awaitStep (StepName "hold") (pure ()) + pure () + +snapshotStaleAwakeablePhaseTwo :: (Workflow :> es, Store :> es, IOE :> es) => Eff es Text +snapshotStaleAwakeablePhaseTwo = do + (_aid, await) <- awakeableNamed (StepName "gate") + _ <- step (StepName "mid") (pure ()) + await + +snapshotStaleChildPhaseOne :: + (Workflow :> es, Store :> es, IOE :> es, Error Store.StoreError :> es) => + WorkflowId -> + Eff es () +snapshotStaleChildPhaseOne childWid = do + _h <- spawnChild (WorkflowName "snapshot-child") childWid shipWorkflow + _ <- + step (StepName "drive") $ + void (runChildWorkflow defaultWorkflowRunOptions (WorkflowName "snapshot-child") childWid shipWorkflow) + (_ :: ()) <- awaitStep (StepName "hold") (pure ()) + pure () + +snapshotStaleChildPhaseTwo :: + (Workflow :> es, Store :> es, IOE :> es) => + WorkflowId -> + Eff es Text +snapshotStaleChildPhaseTwo childWid = do + h <- spawnChild (WorkflowName "snapshot-child") childWid shipWorkflow + _ <- step (StepName "drive") (pure ()) + awaitChild h + +readRequiredAwakeableId :: IORef (Maybe AwakeableId) -> IO AwakeableId +readRequiredAwakeableId ref = + readIORef ref >>= \case + Just aid -> pure aid + Nothing -> fail "workflow did not allocate an awakeable id" + +uuidLiteral :: String -> UUID +uuidLiteral raw = + case fromString raw of + Just uuid -> uuid + Nothing -> error ("invalid UUID literal in test: " <> raw) + +-- | A two-step workflow with a durable sleep between the steps. The sleep's +-- name and delay are parameters so one helper drives both the zero-delta and +-- the real-time tests. +sleepDemoNamed :: + (Workflow :> es, Store :> es, IOE :> es) => + IORef Int -> StepName -> NominalDiffTime -> Eff es (Int, Int) +sleepDemoNamed counter sName delta = do + a <- step (StepName "a") (liftIO (incrementAndRead counter)) + sleepNamed sName delta + b <- step (StepName "b") (liftIO (incrementAndRead counter)) + pure (a, b) + +rollingSleepWorkflow :: + (Workflow :> es, Store :> es, IOE :> es) => + IORef Int -> Eff es Int +rollingSleepWorkflow counter = do + seed <- restoreSeed (0 :: Int) + _ <- step (StepName "work") (liftIO (incrementAndRead counter)) + if seed < 2 + then sleepNamed (StepName "cool") 0 >> continueAsNew (seed + 1) + else pure seed + +rollingAwakeableWorkflow :: + (Workflow :> es, Store :> es, IOE :> es) => + IORef [AwakeableId] -> Eff es Text +rollingAwakeableWorkflow idsRef = do + seed <- restoreSeed (0 :: Int) + (aid, await) <- awakeableNamed (StepName "gate") + liftIO (modifyIORef' idsRef (\ids -> if aid `elem` ids then ids else ids <> [aid])) + value <- await + if seed < 1 + then continueAsNew (seed + 1) + else step (StepName "use") (pure value) + +rotatingParentWorkflow :: + (Workflow :> es, Store :> es, IOE :> es) => + WorkflowId -> Eff es Text +rotatingParentWorkflow childWid = do + seed <- restoreSeed (0 :: Int) + h <- spawnChild (WorkflowName "ship") childWid shipWorkflow + result <- awaitChild h + if seed < 1 + then continueAsNew (seed + 1) + else pure result + +failedChildBeforeRotation :: + (Workflow :> es, Store :> es) => + WorkflowId -> + Eff es Text +failedChildBeforeRotation childWid = do + _ <- spawnChild (WorkflowName "ship") childWid shipWorkflow + awaitStep (StepName "rotation-gate") (pure ()) + +rotatePastFailedChild :: + (Workflow :> es, Store :> es) => + WorkflowId -> + Eff es Text +rotatePastFailedChild childWid = do + _ <- spawnChild (WorkflowName "ship") childWid shipWorkflow + continueAsNew () + +catchFailedChildAfterRotation :: + (Workflow :> es, Store :> es, IOE :> es) => + WorkflowId -> + Eff es Text +catchFailedChildAfterRotation childWid = do + child <- spawnChild (WorkflowName "ship") childWid shipWorkflow + EffException.catch + (awaitChild child) + (\(WorkflowChildFailed _ _ reason) -> pure reason) + +-- | A workflow that records one step, then suspends on an await — so it has a +-- step row but no completion marker (the unfinished-discovery case). +stepThenAwaitWorkflow :: (Workflow :> es, IOE :> es) => IORef Int -> Eff es Int +stepThenAwaitWorkflow counter = do + _ <- step (StepName "s1") (liftIO (incrementAndRead counter)) + awaitStep (StepName "awk:wait") (pure ()) + +-- | A two-step child workflow used in the child-workflow tests. +shipWorkflow :: (Workflow :> es) => Eff es Text +shipWorkflow = do + a <- step (StepName "pack") (pure ("packed" :: Text)) + b <- step (StepName "label") (pure (a <> "+labelled")) + pure b + +-- | A parent that spawns a @"ship"@ child (id supplied), awaits its result, and +-- then records a @notify@ step. Parametrised by child id so each test isolates +-- its own child journal. +parentWorkflow :: (Workflow :> es, Store :> es, IOE :> es) => WorkflowId -> Eff es Text +parentWorkflow childWid = do + h <- spawnChild (WorkflowName "ship") childWid shipWorkflow + result <- awaitChild h + _ <- step (StepName "notify") (pure ("done:" <> result)) + pure ("done:" <> result) + +jsonObjectChildWorkflow :: Eff es Aeson.Value +jsonObjectChildWorkflow = + pure (object ["cancelled" Aeson..= True]) + +jsonObjectParentWorkflow :: (Workflow :> es, Store :> es, IOE :> es) => WorkflowId -> Eff es Aeson.Value +jsonObjectParentWorkflow childWid = do + h <- spawnChild (WorkflowName "json-child") childWid jsonObjectChildWorkflow + result <- awaitChild h + _ <- step (StepName "json-notify") (pure ()) + pure result + +selfCancellingWorkflow :: (Workflow :> es, Store :> es, IOE :> es) => WorkflowName -> WorkflowId -> IORef Int -> Eff es Int +selfCancellingWorkflow name wid counter = do + _ <- step (StepName "one") (liftIO (incrementAndRead counter)) + _ <- + step (StepName "two") $ do + now <- liftIO getCurrentTime + appendJournalEntry name wid (WorkflowCancelled now) + liftIO (incrementAndRead counter) + step (StepName "three") (liftIO (incrementAndRead counter)) + +nominalDays :: Int -> NominalDiffTime +nominalDays n = fromIntegral n * 86400 + +attrKeyText :: AttributeKey Text -> Text +attrKeyText = unkey + +attrKeyTextInt64 :: AttributeKey Int64 -> Text +attrKeyTextInt64 = unkey + +textAttr :: Attributes -> Text -> Maybe Text +textAttr attrs name = case lookupAttribute attrs name of + Just (AttributeValue (TextAttribute t)) -> Just t + _ -> Nothing + +intAttr :: Attributes -> Text -> Maybe Int64 +intAttr attrs name = case lookupAttribute attrs name of + Just (AttributeValue (IntAttribute n)) -> Just n + _ -> Nothing + +-- | A frozen snapshot of an 'ImmutableSpan'. In hs-opentelemetry 1.0 the +-- mutable span fields (name, attributes, status) live behind the +-- @spanHot :: IORef SpanHot@ field rather than directly on 'ImmutableSpan', +-- so the tests read that reference once after the span ends and assert on +-- this flat record. +data CapturedSpan = CapturedSpan + { csName :: Text, + csKind :: SpanKind, + csAttributes :: Attributes, + csStatus :: SpanStatus, + csContext :: SpanContext, + csParent :: Maybe Span + } + +captureSpan :: ImmutableSpan -> IO CapturedSpan +captureSpan sp = do + hot <- readIORef (spanHot sp) + pure + CapturedSpan + { csName = hotName hot, + csKind = spanKind sp, + csAttributes = hotAttributes hot, + csStatus = hotStatus hot, + csContext = spanContext sp, + csParent = spanParent sp + } + +-- | Tiny in-process \"Kafka topic\": an MVar of consumed records plus an +-- incrementing offset. The publisher pushes records here; the consumer +-- drains the MVar. There is no real broker — the goal of the fixture is +-- to validate that the keiro envelope and outbox/inbox semantics +-- compose correctly across two isolated PostgreSQL contexts. +newtype KafkaTopic = KafkaTopic (MVar (Int64, [InboxKafka.KafkaInboundRecord])) + +newKafkaTopic :: IO KafkaTopic +newKafkaTopic = KafkaTopic <$> newMVar (0, []) + +kafkaTopicAccept :: (MonadIO m) => KafkaTopic -> OutboxRow -> m () +kafkaTopicAccept (KafkaTopic ref) row = liftIO $ do + let record = OutboxKafka.outboxRowToKafkaRecord row + headersText = + [ (TE.decodeUtf8 name, TE.decodeUtf8 value) + | (name, value) <- record ^. #headers + ] + now <- getCurrentTime + modifyMVar ref $ \(nextOffset, acc) -> + let inbound = + InboxKafka.KafkaInboundRecord + { topic = record ^. #topic, + partition = 0, + offset = nextOffset, + key = fmap TE.decodeUtf8 (record ^. #key), + payload = record ^. #payload, + headers = headersText, + receivedAt = now + } + in pure ((nextOffset + 1, inbound : acc), ()) + +kafkaTopicPublish :: + forall es. + (IOE :> es) => + KafkaTopic -> + OutboxRow -> + Eff es PublishOutcome +kafkaTopicPublish topic row = do + kafkaTopicAccept topic row + pure PublishSucceeded + +perRow :: + (OutboxRow -> Eff es PublishOutcome) -> + [OutboxRow] -> + Eff es [(OutboxId, PublishOutcome)] +perRow publish rows = + traverse publishOne rows + where + publishOne row = do + outcome <- publish row + pure (row ^. #outboxId, outcome) + +drainKafkaTopic :: KafkaTopic -> IO [InboxKafka.KafkaInboundRecord] +drainKafkaTopic (KafkaTopic ref) = do + (_, acc) <- readMVar ref + pure (reverse acc) + +redeliverWithDifferentOffset :: + InboxKafka.KafkaInboundRecord -> + InboxKafka.KafkaInboundRecord +redeliverWithDifferentOffset record = record & #offset .~ (record ^. #offset) + 1000 + +data ConsumeResult a + = ConsumeDecodeFailed !InboxKafka.KafkaDecodeError + | ConsumePolicyUnsatisfied !InboxError + | ConsumeApplied !(InboxResult a) + deriving stock (Eq, Show) + +-- | A worker-shaped consumer: decode the Kafka record into an +-- IntegrationEvent and run it through the inbox. +consumeAndApply :: + forall es. + (IOE :> es, Store :> es) => + InboxKafka.KafkaInboundRecord -> + (IntegrationEvent -> Tx.Transaction ()) -> + Eff es (ConsumeResult ()) +consumeAndApply record handler = + case InboxKafka.integrationEventFromKafka record of + Left err -> pure (ConsumeDecodeFailed err) + Right (event, kafkaRef) -> do + result <- + runInboxTransaction Nothing PreferIntegrationMessageId event (Just kafkaRef) handler + case result of + Left err -> pure (ConsumePolicyUnsatisfied err) + Right applied -> pure (ConsumeApplied applied) + +billingReactionHandler :: IntegrationEvent -> Tx.Transaction () +billingReactionHandler event = case decodeJsonIntegrationEvent event of + Left _ -> Tx.condemn + Right (OrderSubmittedPayload orderId quantity) -> + Tx.statement (orderId, fromIntegral quantity :: Int64) insertReceivedOrderStmt + +loggingReactionHandler :: Text -> IntegrationEvent -> Tx.Transaction () +loggingReactionHandler _ event = do + -- The cross-context test only needs the (eventType, key) pair, not + -- the decoded payload. + let key = fromMaybe "" (event ^. #key) + Tx.statement (event ^. #source, event ^. #eventType, key) appendBillingEventLogStmt + +insertReceivedOrderStmt :: Statement (Text, Int64) () +insertReceivedOrderStmt = + preparable + """ + INSERT INTO billing_received_orders (order_id, quantity) VALUES ($1, $2) + ON CONFLICT (order_id) DO NOTHING + """ + ( contrazip2 + (E.param (E.nonNullable E.text)) + (E.param (E.nonNullable E.int8)) + ) + D.noResult + +billingReceivedOrdersCountStmt :: Statement () Int +billingReceivedOrdersCountStmt = + preparable + "SELECT COUNT(*)::bigint FROM billing_received_orders" + E.noParams + (D.singleRow (fromIntegral <$> D.column (D.nonNullable D.int8))) + +appendBillingEventLogStmt :: Statement (Text, Text, Text) () +appendBillingEventLogStmt = + preparable + "INSERT INTO billing_event_log (source, event_type, order_id) VALUES ($1, $2, $3)" + ( contrazip3 + (E.param (E.nonNullable E.text)) + (E.param (E.nonNullable E.text)) + (E.param (E.nonNullable E.text)) + ) + D.noResult + +billingEventLogStmt :: Statement () [(Text, Text)] +billingEventLogStmt = + preparable + "SELECT event_type, order_id FROM billing_event_log ORDER BY seq" + E.noParams + ( D.rowList + ( (,) + <$> D.column (D.nonNullable D.text) + <*> D.column (D.nonNullable D.text) + ) + ) + +orderSubmittedEnvelope :: Text -> Int -> Text -> IntegrationEvent +orderSubmittedEnvelope orderId quantity messageId = + encodeJsonIntegrationEvent + ( sampleIntegrationEnvelope + & #messageId + .~ messageId + & #eventType + .~ "OrderSubmitted" + & #key + .~ Just orderId + ) + (OrderSubmittedPayload orderId quantity) + +orderCancelledEnvelope :: Text -> Text -> IntegrationEvent +orderCancelledEnvelope orderId messageId = + sampleIntegrationEnvelope + & #messageId + .~ messageId + & #eventType + .~ "OrderCancelled" + & #key + .~ Just orderId + & #payloadBytes + .~ ("{\"orderId\":\"" <> TE.encodeUtf8 orderId <> "\"}") + & #contentType + .~ ApplicationJson + +inboxTestCounterInsertStmt :: Statement Text () +inboxTestCounterInsertStmt = + preparable + "INSERT INTO inbox_test_counter (message_id) VALUES ($1)" + (E.param (E.nonNullable E.text)) + D.noResult + +inboxTestCounterCountStmt :: Statement () Int +inboxTestCounterCountStmt = + preparable + "SELECT COUNT(*)::bigint FROM inbox_test_counter" + E.noParams + (D.singleRow (fromIntegral <$> D.column (D.nonNullable D.int8))) + +sampleProducer :: IntegrationProducer () +sampleProducer = + IntegrationProducer + { name = "ordering-integration-producer", + source = "ordering", + messageIdPrefix = "msg", + mapEvent = \_recorded () -> Just sampleDraft + } + +sampleDraft :: IntegrationEventDraft +sampleDraft = + IntegrationEventDraft + { destination = "billing.orders.v1", + key = Just "order-123", + eventType = "OrderSubmitted", + schemaVersion = 1, + contentType = ApplicationJson, + schemaReference = Nothing, + sourceEventId = Nothing, + sourceGlobalPosition = Nothing, + payloadBytes = "{\"orderId\":\"order-123\",\"quantity\":5}", + occurredAt = UTCTime (ModifiedJulianDay 60000) (secondsToDiffTime 0), + causationId = Nothing, + correlationId = Nothing, + traceContext = Nothing, + attributes = Just (object ["source" Aeson..= ("test-suite" :: Text)]) + } + +sampleOutboxRow :: IntegrationEvent -> OutboxRow +sampleOutboxRow event = + OutboxRow + { outboxId = OutboxId outboxUuid1, + event, + status = OutboxPending, + attemptCount = 0, + nextAttemptAt = UTCTime (ModifiedJulianDay 60000) (secondsToDiffTime 0), + lastError = Nothing, + publishedAt = Nothing, + createdAt = UTCTime (ModifiedJulianDay 60000) (secondsToDiffTime 0), + updatedAt = UTCTime (ModifiedJulianDay 60000) (secondsToDiffTime 0) + } + +backdateOutboxUpdatedAt :: (Store :> es) => OutboxId -> UTCTime -> Eff es () +backdateOutboxUpdatedAt oid timestamp = + Store.runTransaction $ + Tx.statement (unOutboxId oid, timestamp) backdateOutboxUpdatedAtStmt + +backdateOutboxUpdatedAtStmt :: Statement (UUID, UTCTime) () +backdateOutboxUpdatedAtStmt = + preparable + "UPDATE keiro.keiro_outbox SET updated_at = $2 WHERE outbox_id = $1" + ( contrazip2 + (E.param (E.nonNullable E.uuid)) + (E.param (E.nonNullable E.timestamptz)) + ) + D.noResult + +backdateOutboxPublishedAt :: (Store :> es) => OutboxId -> UTCTime -> Eff es () +backdateOutboxPublishedAt oid timestamp = + Store.runTransaction $ + Tx.statement (unOutboxId oid, timestamp) backdateOutboxPublishedAtStmt + +backdateOutboxPublishedAtStmt :: Statement (UUID, UTCTime) () +backdateOutboxPublishedAtStmt = + preparable + "UPDATE keiro.keiro_outbox SET published_at = $2 WHERE outbox_id = $1" + ( contrazip2 + (E.param (E.nonNullable E.uuid)) + (E.param (E.nonNullable E.timestamptz)) + ) + D.noResult + +outboxUuid1, outboxUuid2, outboxUuid3, outboxUuid4 :: UUID +outboxUuid1 = case fromString "018f0f18-0000-7000-8000-000000000a01" of + Just uuid -> uuid + Nothing -> error "invalid outbox uuid 1" +outboxUuid2 = case fromString "018f0f18-0000-7000-8000-000000000a02" of + Just uuid -> uuid + Nothing -> error "invalid outbox uuid 2" +outboxUuid3 = case fromString "018f0f18-0000-7000-8000-000000000a03" of + Just uuid -> uuid + Nothing -> error "invalid outbox uuid 3" +outboxUuid4 = case fromString "018f0f18-0000-7000-8000-000000000a04" of + Just uuid -> uuid + Nothing -> error "invalid outbox uuid 4" + +outboxIdFromOrdinal :: Word64 -> OutboxId +outboxIdFromOrdinal n = + OutboxId (fromWords64 0x018f0f1800007000 (0x8000000000000000 + n)) + +uniqueIds :: (Eq a) => [a] -> [a] +uniqueIds = foldr (\x xs -> if x `elem` xs then xs else x : xs) [] + +data OrderSubmittedPayload = OrderSubmittedPayload + { orderId :: !Text, + quantity :: !Int + } + deriving stock (Generic, Eq, Show) + +instance ToJSON OrderSubmittedPayload where + toJSON = genericToJSON (aesonPrefix camelCase) + toEncoding = genericToEncoding (aesonPrefix camelCase) + +instance FromJSON OrderSubmittedPayload where + parseJSON = genericParseJSON (aesonPrefix camelCase) + +sampleIntegrationEnvelope :: IntegrationEvent +sampleIntegrationEnvelope = + IntegrationEvent + { messageId = "018f0f18-17aa-7000-8000-0000000000aa", + source = "ordering", + destination = "billing.orders.v1", + key = Just "order-123", + eventType = "OrderSubmitted", + schemaVersion = 1, + contentType = ApplicationJson, + schemaReference = + Just + SchemaReference + { registry = Just "https://schemas.example/registry", + subject = Just "billing.orders.v1.OrderSubmitted", + version = Just 1, + schemaId = Just 42, + fingerprint = Just "sha256:abc123" + }, + sourceEventId = Just (EventId integrationSourceEventUuid), + sourceGlobalPosition = Just (GlobalPosition 42), + payloadBytes = "{\"orderId\":\"order-123\",\"quantity\":5}", + occurredAt = UTCTime (ModifiedJulianDay 60000) (secondsToDiffTime 0), + causationId = Just (EventId integrationCausationUuid), + correlationId = Just (EventId integrationCorrelationUuid), + traceContext = + Just + TraceContext + { traceparent = "00-0af7651916cd43dd8448eb211c80319c-b7ad6b7169203331-01", + tracestate = Just "rojo=00f067aa0ba902b7" + }, + attributes = Nothing + } + +integrationSourceEventUuid :: UUID +integrationSourceEventUuid = + case fromString "018f0f18-17aa-7000-8000-000000000003" of + Just uuid -> uuid + Nothing -> error "invalid integration source event UUID" + +integrationCausationUuid :: UUID +integrationCausationUuid = + case fromString "018f0f18-17aa-7000-8000-000000000004" of + Just uuid -> uuid + Nothing -> error "invalid integration causation UUID" + +integrationCorrelationUuid :: UUID +integrationCorrelationUuid = + case fromString "018f0f18-17aa-7000-8000-000000000005" of + Just uuid -> uuid + Nothing -> error "invalid integration correlation UUID" + +data OrderStream + +data OrderEvent + = OrderPlaced !Text !Int + deriving stock (Generic, Eq, Show) + +data OrderState + = Idle + deriving stock (Generic, Eq, Show) + +data OrderCommand + = PlaceOrder + deriving stock (Generic, Eq, Show) + +orderCodec :: Codec OrderEvent +orderCodec = + Codec + { eventTypes = EventType "OrderPlaced" :| [], + eventType = \case + OrderPlaced {} -> EventType "OrderPlaced", + schemaVersion = 2, + encode = \case + OrderPlaced orderId quantity -> + object ["orderId" Aeson..= orderId, "quantity" Aeson..= quantity], + decode = parseOrderPlaced, + upcasters = [(1, const upcastOrderPlacedV1)] + } + +gappyCodec :: Codec OrderEvent +gappyCodec = + Codec + { eventTypes = orderCodec ^. #eventTypes, + eventType = orderCodec ^. #eventType, + schemaVersion = 4, + encode = orderCodec ^. #encode, + decode = orderCodec ^. #decode, + upcasters = [(1, const upcastOrderPlacedV1), (3, const Right)] + } + +parseOrderPlaced :: EventType -> Value -> Either Text OrderEvent +parseOrderPlaced _ value = + case parseEither parser value of + Right event -> Right event + Left message -> Left (fromStringLiteral message) + where + parser = withObject "OrderPlaced" $ \objectValue -> + OrderPlaced + <$> objectValue .: "orderId" + <*> objectValue .: "quantity" + +upcastOrderPlacedV1 :: Value -> Either Text Value +upcastOrderPlacedV1 value = + case parseEither parser value of + Right migrated -> Right migrated + Left message -> Left (fromStringLiteral message) + where + parser = withObject "OrderPlacedV1" $ \objectValue -> do + orderId <- objectValue .: "orderId" + quantity <- objectValue .: "qty" + pure (object ["orderId" Aeson..= (orderId :: Text), "quantity" Aeson..= (quantity :: Int)]) + +metadataForOrDie :: Int -> Maybe Value -> Value +metadataForOrDie version existing = + either (error . show) id (metadataFor version existing) + +emptyTransducer :: SymTransducer () '[] OrderState OrderCommand OrderEvent +emptyTransducer = + SymTransducer + { edgesOut = \_ -> [], + initial = Idle, + initialRegs = RNil, + isFinal = \_ -> True + } + +type CounterEventStream = EventStream (HsPred '[] CounterCommand) '[] CounterState CounterCommand CounterEvent + +type ValidatedCounterEventStream = ValidatedEventStream (HsPred '[] CounterCommand) '[] CounterState CounterCommand CounterEvent + +type SnapshotCounterRegs = '[ '("lastAmount", Int)] + +type UninitializedSnapshotRegs = '[ '("initialized", Int), '("neverWritten", Int)] + +type SnapshotCounterEventStream = EventStream (HsPred SnapshotCounterRegs CounterCommand) SnapshotCounterRegs CounterState CounterCommand CounterEvent + +type PartialSnapshotEventStream = EventStream (HsPred SnapshotCounterRegs CounterCommand) SnapshotCounterRegs PartialSnapshotState CounterCommand CounterEvent + +type ValidatedSnapshotCounterEventStream = ValidatedEventStream (HsPred SnapshotCounterRegs CounterCommand) SnapshotCounterRegs CounterState CounterCommand CounterEvent + +type UninitializedSnapshotEventStream = EventStream (HsPred UninitializedSnapshotRegs CounterCommand) UninitializedSnapshotRegs CounterState CounterCommand CounterEvent + +data CounterCommand + = Add !Int + deriving stock (Generic, Eq, Show) + +data SkipCommand + = SAdd !Int + | SSkip + deriving stock (Generic, Eq, Show) + +data CounterEvent + = CounterAdded !Int + | CounterAudited !Int + deriving stock (Generic, Eq, Show) + +data CounterState + = Counting + deriving stock (Generic, Eq, Show, Enum, Bounded, Ord) + deriving anyclass (FromJSON, ToJSON) + +instance CanonicalStateShape CounterState + +data CounterStateV2 + = CountingV2 + | PausedV2 + deriving stock (Generic, Eq, Show, Enum, Bounded, Ord) + deriving anyclass (FromJSON, ToJSON) + +instance CanonicalStateShape CounterStateV2 + +data DrainState + = Draining + | Drained + deriving stock (Generic, Eq, Show, Enum, Bounded, Ord) + +data PartialSnapshotState + = SnapshotEncodable + | SnapshotEncodeBomb + deriving stock (Generic, Eq, Show, Enum, Bounded, Ord) + +instance CanonicalStateShape PartialSnapshotState + +instance ToJSON PartialSnapshotState where + toJSON SnapshotEncodable = Aeson.String "encodable" + toJSON SnapshotEncodeBomb = error "snapshot state encoder exploded" + +instance FromJSON PartialSnapshotState where + parseJSON = Aeson.withText "PartialSnapshotState" $ \case + "encodable" -> pure SnapshotEncodable + "bomb" -> pure SnapshotEncodeBomb + other -> fail ("unknown partial snapshot state: " <> Text.unpack other) + +counterEventStreamDef :: CounterEventStream +counterEventStreamDef = + EventStream + { transducer = counterTransducer, + initialState = Counting, + initialRegisters = RNil, + eventCodec = counterCodec, + resolveStreamName = Stream.streamName, + snapshotPolicy = Never, + stateCodec = Nothing + } + +counterEventStream :: ValidatedCounterEventStream +counterEventStream = mkEventStreamOrThrow "counter" counterEventStreamDef + +auditedCounterEventStream :: ValidatedCounterEventStream +auditedCounterEventStream = + mkEventStreamOrThrow + "counter-audited-only" + (counterEventStreamDef & #transducer .~ auditedCounterTransducer) + +auditedCounterTransducer :: SymTransducer (HsPred '[] CounterCommand) '[] CounterState CounterCommand CounterEvent +auditedCounterTransducer = + SymTransducer + { edgesOut = \case + Counting -> + [ Edge + { guard = matchInCtor addCtor, + update = UKeep, + output = [pack addCtor counterAuditedCtor (inpCtor addCtor #amount *: oNil)], + target = Counting, + mode = Keiki.Live + } + ], + initial = Counting, + initialRegs = RNil, + isFinal = \_ -> False + } + +noOpCounterEventStreamDef :: CounterEventStream +noOpCounterEventStreamDef = + counterEventStreamDef & #transducer .~ noOpCounterTransducer + +noOpCounterEventStream :: ValidatedCounterEventStream +noOpCounterEventStream = mkEventStreamOrThrow "counter-no-op" noOpCounterEventStreamDef + +counterTransducer :: SymTransducer (HsPred '[] CounterCommand) '[] CounterState CounterCommand CounterEvent +counterTransducer = + SymTransducer + { edgesOut = \case + Counting -> + [ Edge + { guard = matchInCtor addCtor, + update = UKeep, + output = [pack addCtor counterAddedCtor (inpCtor addCtor #amount *: oNil)], + target = Counting, + mode = Keiki.Live + } + ], + initial = Counting, + initialRegs = RNil, + isFinal = \_ -> False + } + +noOpCounterTransducer :: SymTransducer (HsPred '[] CounterCommand) '[] CounterState CounterCommand CounterEvent +noOpCounterTransducer = + SymTransducer + { edgesOut = \case + Counting -> + [ Edge + { guard = matchInCtor addCtor, + update = UKeep, + output = [], + target = Counting, + mode = Keiki.Live + } + ], + initial = Counting, + initialRegs = RNil, + isFinal = \_ -> False + } + +multiCounterEventStreamDef :: CounterEventStream +multiCounterEventStreamDef = + counterEventStreamDef & #transducer .~ multiCounterTransducer + +multiCounterEventStream :: ValidatedCounterEventStream +multiCounterEventStream = mkEventStreamOrThrow "counter-multi" multiCounterEventStreamDef + +multiCounterTransducer :: SymTransducer (HsPred '[] CounterCommand) '[] CounterState CounterCommand CounterEvent +multiCounterTransducer = + SymTransducer + { edgesOut = \case + Counting -> + [ Edge + { guard = matchInCtor addCtor, + update = UKeep, + output = + [ pack addCtor counterAddedCtor (inpCtor addCtor #amount *: oNil), + pack addCtor counterAuditedCtor (inpCtor addCtor #amount *: oNil) + ], + target = Counting, + mode = Keiki.Live + } + ], + initial = Counting, + initialRegs = RNil, + isFinal = \_ -> False + } + +-- | Both guards match at runtime but remain outside keiki's conservative pure +-- overlap fragment. Distinct head event constructors keep inversion unambiguous, +-- so this is a validated stream that exercises the runtime step witness. +ambiguousCounterEventStreamDef :: CounterEventStream +ambiguousCounterEventStreamDef = + counterEventStreamDef & #transducer .~ ambiguousCounterTransducer + +ambiguousCounterEventStream :: ValidatedCounterEventStream +ambiguousCounterEventStream = + mkEventStreamOrThrow "counter-ambiguous" ambiguousCounterEventStreamDef + +ambiguousCounterTransducer :: SymTransducer (HsPred '[] CounterCommand) '[] CounterState CounterCommand CounterEvent +ambiguousCounterTransducer = + counterTransducer + { edgesOut = \case + Counting -> + [ Edge + { guard = ambiguousGuard, + update = UKeep, + output = [pack addCtor counterAddedCtor (inpCtor addCtor #amount *: oNil)], + target = Counting, + mode = Keiki.Live + }, + Edge + { guard = ambiguousGuard, + update = UKeep, + output = [pack addCtor counterAuditedCtor (inpCtor addCtor #amount *: oNil)], + target = Counting, + mode = Keiki.Live + } + ] + } + where + ambiguousGuard = PAnd (matchInCtor addCtor) (PNot PBot) + +snapshotCounterEventStreamDef :: SnapshotCounterEventStream +snapshotCounterEventStreamDef = + EventStream + { transducer = snapshotCounterTransducer, + initialState = Counting, + initialRegisters = RCons (Proxy @"lastAmount") 0 RNil, + eventCodec = counterCodec, + resolveStreamName = Stream.streamName, + snapshotPolicy = Every 2, + stateCodec = Just (defaultStateCodec @SnapshotCounterRegs @CounterState 1) + } + +partialSnapshotEventStream :: ValidatedEventStream (HsPred SnapshotCounterRegs CounterCommand) SnapshotCounterRegs PartialSnapshotState CounterCommand CounterEvent +partialSnapshotEventStream = mkEventStreamOrThrow "partial-snapshot" partialSnapshotEventStreamDef + +partialSnapshotEventStreamDef :: PartialSnapshotEventStream +partialSnapshotEventStreamDef = + EventStream + { transducer = + SymTransducer + { edgesOut = \_ -> + [ Edge + { guard = matchInCtor addCtor, + update = + USet + (#lastAmount :: IndexN "lastAmount" SnapshotCounterRegs Int) + (inpCtor addCtor #amount), + output = [pack addCtor counterAddedCtor (inpCtor addCtor #amount *: oNil)], + target = SnapshotEncodeBomb, + mode = Keiki.Live + } + ], + initial = SnapshotEncodable, + initialRegs = RCons (Proxy @"lastAmount") 0 RNil, + isFinal = \_ -> False + }, + initialState = SnapshotEncodable, + initialRegisters = RCons (Proxy @"lastAmount") 0 RNil, + eventCodec = counterCodec, + resolveStreamName = Stream.streamName, + snapshotPolicy = Every 1, + stateCodec = Just (defaultStateCodec @SnapshotCounterRegs @PartialSnapshotState 1) + } + +uninitializedSnapshotEventStreamDef :: UninitializedSnapshotEventStream +uninitializedSnapshotEventStreamDef = + initializedSnapshotEventStreamDef + & #initialRegisters + .~ RCons (Proxy @"initialized") 0 (emptyRegFile @'[ '("neverWritten", Int)]) + +initializedSnapshotEventStreamDef :: UninitializedSnapshotEventStream +initializedSnapshotEventStreamDef = + EventStream + { transducer = + SymTransducer + { edgesOut = \case Counting -> [], + initial = Counting, + initialRegs = RCons (Proxy @"initialized") 0 (RCons (Proxy @"neverWritten") 0 RNil), + isFinal = \_ -> False + }, + initialState = Counting, + initialRegisters = RCons (Proxy @"initialized") 0 (RCons (Proxy @"neverWritten") 0 RNil), + eventCodec = counterCodec, + resolveStreamName = Stream.streamName, + snapshotPolicy = Every 2, + stateCodec = Just (defaultStateCodec @UninitializedSnapshotRegs @CounterState 1) + } + +snapshotCounterEventStream :: ValidatedSnapshotCounterEventStream +snapshotCounterEventStream = mkEventStreamOrThrow "snapshot-counter" snapshotCounterEventStreamDef + +snapshotCounterTransducer :: SymTransducer (HsPred SnapshotCounterRegs CounterCommand) SnapshotCounterRegs CounterState CounterCommand CounterEvent +snapshotCounterTransducer = + SymTransducer + { edgesOut = \case + Counting -> + [ Edge + { guard = matchInCtor addCtor, + update = + USet + (#lastAmount :: IndexN "lastAmount" SnapshotCounterRegs Int) + (inpCtor addCtor #amount), + output = [pack addCtor counterAddedCtor (inpCtor addCtor #amount *: oNil)], + target = Counting, + mode = Keiki.Live + } + ], + initial = Counting, + initialRegs = RCons (Proxy @"lastAmount") 0 RNil, + isFinal = \_ -> False + } + +foldV1SnapshotCounterEventStream :: ValidatedSnapshotCounterEventStream +foldV1SnapshotCounterEventStream = + mkEventStreamOrThrow "snapshot-counter-fold-v1" foldV1SnapshotCounterEventStreamDef + +foldV1SnapshotCounterEventStreamDef :: SnapshotCounterEventStream +foldV1SnapshotCounterEventStreamDef = + snapshotCounterEventStreamDef + { transducer = foldV1SnapshotCounterTransducer, + stateCodec = + Just + ( defaultStateCodecWithFold + @SnapshotCounterRegs + @CounterState + (FoldVersion "fold-v1") + 1 + ) + } + +foldV2SnapshotCounterEventStream :: ValidatedSnapshotCounterEventStream +foldV2SnapshotCounterEventStream = + mkEventStreamOrThrow "snapshot-counter-fold-v2" foldV2SnapshotCounterEventStreamDef + +foldV2SnapshotCounterEventStreamDef :: SnapshotCounterEventStream +foldV2SnapshotCounterEventStreamDef = + foldV1SnapshotCounterEventStreamDef + { transducer = foldV2SnapshotCounterTransducer, + snapshotPolicy = Every 1, + stateCodec = + Just + ( defaultStateCodecWithFold + @SnapshotCounterRegs + @CounterState + (FoldVersion "fold-v2") + 1 + ) + } + +foldV2WithoutFingerprintBumpEventStream :: ValidatedSnapshotCounterEventStream +foldV2WithoutFingerprintBumpEventStream = + mkEventStreamOrThrow + "snapshot-counter-fold-v2-without-fingerprint-bump" + foldV2WithoutFingerprintBumpEventStreamDef + +foldV2WithoutFingerprintBumpEventStreamDef :: SnapshotCounterEventStream +foldV2WithoutFingerprintBumpEventStreamDef = + foldV2SnapshotCounterEventStreamDef + { stateCodec = + Just + ( defaultStateCodecWithFold + @SnapshotCounterRegs + @CounterState + (FoldVersion "fold-v1") + 1 + ) + } + +foldV1SnapshotCounterTransducer :: SymTransducer (HsPred SnapshotCounterRegs CounterCommand) SnapshotCounterRegs CounterState CounterCommand CounterEvent +foldV1SnapshotCounterTransducer = + foldSnapshotCounterTransducer + (inpCtor addCtor #amount) + +foldV2SnapshotCounterTransducer :: SymTransducer (HsPred SnapshotCounterRegs CounterCommand) SnapshotCounterRegs CounterState CounterCommand CounterEvent +foldV2SnapshotCounterTransducer = + foldSnapshotCounterTransducer + (inpCtor addCtor #amount K..+ lit 1) + +foldSnapshotCounterTransducer :: + Keiki.Term SnapshotCounterRegs CounterCommand AddFields Int -> + SymTransducer (HsPred SnapshotCounterRegs CounterCommand) SnapshotCounterRegs CounterState CounterCommand CounterEvent +foldSnapshotCounterTransducer nextLastAmount = + SymTransducer + { edgesOut = \case + Counting -> + [ Edge + { guard = + PAnd + (matchInCtor addCtor) + (inpCtor addCtor #amount K..< lit 100), + update = + USet + (#lastAmount :: IndexN "lastAmount" SnapshotCounterRegs Int) + nextLastAmount, + output = [pack addCtor counterAddedCtor (inpCtor addCtor #amount *: oNil)], + target = Counting, + mode = Keiki.Live + }, + Edge + { guard = + PAnd + (matchInCtor addCtor) + ( PAnd + (inpCtor addCtor #amount K..>= lit 100) + ( inpCtor addCtor #amount + .== (proj (#lastAmount :: Keiki.Index SnapshotCounterRegs Int) K..+ lit 100) + ) + ), + update = UKeep, + output = [pack addCtor counterAuditedCtor (inpCtor addCtor #amount *: oNil)], + target = Counting, + mode = Keiki.Live + } + ], + initial = Counting, + initialRegs = RCons (Proxy @"lastAmount") 0 RNil, + isFinal = \_ -> False + } + +multiSnapshotCounterEventStreamDef :: SnapshotCounterEventStream +multiSnapshotCounterEventStreamDef = + snapshotCounterEventStreamDef + & #transducer + .~ multiSnapshotCounterTransducer + & #snapshotPolicy + .~ Every 1 + +multiSnapshotCounterEventStream :: ValidatedSnapshotCounterEventStream +multiSnapshotCounterEventStream = mkEventStreamOrThrow "snapshot-counter-multi" multiSnapshotCounterEventStreamDef + +multiSnapshotCounterTransducer :: SymTransducer (HsPred SnapshotCounterRegs CounterCommand) SnapshotCounterRegs CounterState CounterCommand CounterEvent +multiSnapshotCounterTransducer = + SymTransducer + { edgesOut = \case + Counting -> + [ Edge + { guard = matchInCtor addCtor, + update = + USet + (#lastAmount :: IndexN "lastAmount" SnapshotCounterRegs Int) + (inpCtor addCtor #amount), + output = + [ pack addCtor counterAddedCtor (inpCtor addCtor #amount *: oNil), + pack addCtor counterAuditedCtor (inpCtor addCtor #amount *: oNil) + ], + target = Counting, + mode = Keiki.Live + } + ], + initial = Counting, + initialRegs = RCons (Proxy @"lastAmount") 0 RNil, + isFinal = \_ -> False + } + +guardedSnapshotCounterEventStreamDef :: SnapshotCounterEventStream +guardedSnapshotCounterEventStreamDef = + snapshotCounterEventStreamDef & #transducer .~ guardedSnapshotCounterTransducer + +guardedSnapshotCounterEventStream :: ValidatedSnapshotCounterEventStream +guardedSnapshotCounterEventStream = mkEventStreamOrThrow "snapshot-counter-guarded" guardedSnapshotCounterEventStreamDef + +guardedSnapshotCounterTransducer :: SymTransducer (HsPred SnapshotCounterRegs CounterCommand) SnapshotCounterRegs CounterState CounterCommand CounterEvent +guardedSnapshotCounterTransducer = + SymTransducer + { edgesOut = \case + Counting -> + [ Edge + { guard = + PAnd + (matchInCtor addCtor) + (inpCtor addCtor #amount .== proj (#lastAmount :: Keiki.Index SnapshotCounterRegs Int)), + update = + USet + (#lastAmount :: IndexN "lastAmount" SnapshotCounterRegs Int) + (inpCtor addCtor #amount), + output = [pack addCtor counterAddedCtor (inpCtor addCtor #amount *: oNil)], + target = Counting, + mode = Keiki.Live + } + ], + initial = Counting, + initialRegs = RCons (Proxy @"lastAmount") 0 RNil, + isFinal = \_ -> False + } + +-- | A deliberately replay-unsafe stream: its single edge is an ε-edge +-- (empty @output@) whose @update@ reads the command's @amount@. Because +-- the edge emits no event, that command field cannot be recovered on +-- replay, so keiki's hidden-input check flags it. Used to prove +-- 'validateEventStream' / 'mkEventStream' reject an unsafe stream. +brokenHiddenInputEventStream :: SnapshotCounterEventStream +brokenHiddenInputEventStream = + snapshotCounterEventStreamDef & #transducer .~ brokenHiddenInputTransducer + +brokenHiddenInputTransducer :: SymTransducer (HsPred SnapshotCounterRegs CounterCommand) SnapshotCounterRegs CounterState CounterCommand CounterEvent +brokenHiddenInputTransducer = + SymTransducer + { edgesOut = \case + Counting -> + [ Edge + { guard = matchInCtor addCtor, + update = + USet + (#lastAmount :: IndexN "lastAmount" SnapshotCounterRegs Int) + (inpCtor addCtor #amount), + output = [], + target = Counting, + mode = Keiki.Live + } + ], + initial = Counting, + initialRegs = RCons (Proxy @"lastAmount") 0 RNil, + isFinal = \_ -> False + } + +-- | A multi-event edge whose tail carries the command field omitted from its +-- head. The union of the outputs covers @amount@, but replay commits to an edge +-- by inverting only the head, so the stored chain cannot reconstruct @Add@. +headUnrecoverableEventStreamDef :: CounterEventStream +headUnrecoverableEventStreamDef = + counterEventStreamDef & #transducer .~ headUnrecoverableTransducer + +headUnrecoverableEventStream :: ValidatedCounterEventStream +headUnrecoverableEventStream = mkEventStreamUnchecked headUnrecoverableEventStreamDef + +headUnrecoverableTransducer :: SymTransducer (HsPred '[] CounterCommand) '[] CounterState CounterCommand CounterEvent +headUnrecoverableTransducer = + counterTransducer + { edgesOut = \case + Counting -> + [ Edge + { guard = matchInCtor addCtor, + update = UKeep, + output = + [ pack addCtor counterAddedCtor (Keiki.lit 0 *: oNil), + pack addCtor counterAuditedCtor (inpCtor addCtor #amount *: oNil) + ], + target = Counting, + mode = Keiki.Live + } + ] + } + +-- | Two edges share a head wire constructor, so one stored event can invert +-- through both. The double-negated guard is true at runtime but deliberately +-- outside keiki's pure overlap fragment, isolating the inversion warning from +-- the separate conservative determinism check. +inversionAmbiguousEventStreamDef :: CounterEventStream +inversionAmbiguousEventStreamDef = + counterEventStreamDef & #transducer .~ inversionAmbiguousTransducer + +inversionAmbiguousEventStream :: ValidatedCounterEventStream +inversionAmbiguousEventStream = + case mkEventStreamWith + Keiki.defaultValidationOptions {Keiki.checkInversionAmbiguity = False} + "counter-inversion-ambiguous" + inversionAmbiguousEventStreamDef of + Right validated -> validated + Left warnings -> error ("expected inversion-ambiguity override to validate: " <> show warnings) + +inversionAmbiguousTransducer :: SymTransducer (HsPred '[] CounterCommand) '[] CounterState CounterCommand CounterEvent +inversionAmbiguousTransducer = + counterTransducer + { edgesOut = \case + Counting -> + [ ambiguousEdge, + ambiguousEdge + ] + } + where + ambiguousEdge = + Edge + { guard = PAnd (matchInCtor addCtor) (PNot PBot), + update = UKeep, + output = [pack addCtor counterAddedCtor (inpCtor addCtor #amount *: oNil)], + target = Counting, + mode = Keiki.Live + } + +-- | This edge reads @Add.amount@ while guarded only by @PTop@. A different +-- command constructor would reach the partial projection and crash instead of +-- being rejected. +unguardedInputReadEventStreamDef :: CounterEventStream +unguardedInputReadEventStreamDef = + counterEventStreamDef & #transducer .~ unguardedInputReadTransducer + +unguardedInputReadTransducer :: SymTransducer (HsPred '[] CounterCommand) '[] CounterState CounterCommand CounterEvent +unguardedInputReadTransducer = + counterTransducer + { edgesOut = \case + Counting -> + [ Edge + { guard = PTop, + update = UKeep, + output = [pack addCtor counterAddedCtor (inpCtor addCtor #amount *: oNil)], + target = Counting, + mode = Keiki.Live + } + ] + } + +-- | A silent self-loop that writes a register. With no emitted event the +-- write cannot be reconstructed from the durable log. +stateChangingEpsilonEventStreamDef :: SnapshotCounterEventStream +stateChangingEpsilonEventStreamDef = + snapshotCounterEventStreamDef & #transducer .~ stateChangingEpsilonTransducer + +stateChangingEpsilonTransducer :: SymTransducer (HsPred SnapshotCounterRegs CounterCommand) SnapshotCounterRegs CounterState CounterCommand CounterEvent +stateChangingEpsilonTransducer = + snapshotCounterTransducer + { edgesOut = \case + Counting -> + [ Edge + { guard = matchInCtor addCtor, + update = + USet + (#lastAmount :: IndexN "lastAmount" SnapshotCounterRegs Int) + (Keiki.lit 0), + output = [], + target = Counting, + mode = Keiki.Live + } + ] + } + +type SilentMoveEventStream = EventStream (HsPred '[] CounterCommand) '[] DrainState CounterCommand CounterEvent + +silentMoveEventStreamDef :: SilentMoveEventStream +silentMoveEventStreamDef = + EventStream + { transducer = silentMoveTransducer, + initialState = Draining, + initialRegisters = RNil, + eventCodec = counterCodec, + resolveStreamName = Stream.streamName, + snapshotPolicy = Never, + stateCodec = Nothing + } + +silentMoveTransducer :: SymTransducer (HsPred '[] CounterCommand) '[] DrainState CounterCommand CounterEvent +silentMoveTransducer = + SymTransducer + { edgesOut = \case + Draining -> + [ Edge + { guard = matchInCtor addCtor, + update = UKeep, + output = [], + target = Drained, + mode = Keiki.Live + } + ] + Drained -> [], + initial = Draining, + initialRegs = RNil, + isFinal = (== Drained) + } + +isStateChangingEpsilon :: Keiki.TransducerValidationWarning s -> Bool +isStateChangingEpsilon = \case + Keiki.StateChangingEpsilon {} -> True + _ -> False + +expectValidationWarning :: + (Bounded s, Enum s, Ord s, Show s) => + Text -> + Text -> + EventStream (HsPred rs ci) rs s ci co -> + Expectation +expectValidationWarning label prefix eventStream = + case mkEventStream label eventStream of + Left warnings -> do + map eswStreamLabel warnings `shouldSatisfy` all (== label) + map eswReason warnings `shouldSatisfy` any (Text.isInfixOf prefix) + Right _ -> + expectationFailure + ( "expected mkEventStream to reject " + <> Text.unpack label + <> " with warning prefix " + <> Text.unpack prefix + ) + +type AddFields = '[ '("amount", Int)] + +type SkipEventStream = EventStream (HsPred '[] SkipCommand) '[] CounterState SkipCommand CounterEvent + +type ValidatedSkipEventStream = ValidatedEventStream (HsPred '[] SkipCommand) '[] CounterState SkipCommand CounterEvent + +skipEventStream :: ValidatedSkipEventStream +skipEventStream = mkEventStreamOrThrow "skip-command" skipEventStreamDef + +skipEventStreamDef :: SkipEventStream +skipEventStreamDef = + EventStream + { transducer = skipTransducer, + initialState = Counting, + initialRegisters = RNil, + eventCodec = counterCodec, + resolveStreamName = Stream.streamName, + snapshotPolicy = Never, + stateCodec = Nothing + } + +skipTransducer :: SymTransducer (HsPred '[] SkipCommand) '[] CounterState SkipCommand CounterEvent +skipTransducer = + SymTransducer + { edgesOut = \case + Counting -> + [ Edge + { guard = matchInCtor sAddCtor, + update = UKeep, + output = [pack sAddCtor counterAddedCtor (inpCtor sAddCtor #amount *: oNil)], + target = Counting, + mode = Keiki.Live + }, + Edge + { guard = matchInCtor sSkipCtor, + update = UKeep, + output = [], + target = Counting, + mode = Keiki.Live + } + ], + initial = Counting, + initialRegs = RNil, + isFinal = \_ -> False + } + +sAddCtor :: InCtor SkipCommand AddFields +sAddCtor = + InCtor + { icName = "SAdd", + icMatch = \case + SAdd amount -> Just (RCons Proxy amount RNil) + SSkip -> Nothing, + icBuild = \case + RCons _ amount RNil -> SAdd amount + } + +sSkipCtor :: InCtor SkipCommand '[] +sSkipCtor = + InCtor + { icName = "SSkip", + icMatch = \case + SAdd {} -> Nothing + SSkip -> Just RNil, + icBuild = \case + RNil -> SSkip + } + +addCtor :: InCtor CounterCommand AddFields +addCtor = + InCtor + { icName = "Add", + icMatch = \case + Add amount -> Just (RCons Proxy amount RNil), + icBuild = \case + RCons _ amount RNil -> Add amount + } + +counterAddedCtor :: WireCtor CounterEvent (Int, ()) +counterAddedCtor = + WireCtor + { wcName = "CounterAdded", + wcMatch = \case + CounterAdded amount -> Just (amount, ()) + CounterAudited {} -> Nothing, + wcBuild = \case + (amount, ()) -> CounterAdded amount + } + +counterAuditedCtor :: WireCtor CounterEvent (Int, ()) +counterAuditedCtor = + WireCtor + { wcName = "CounterAudited", + wcMatch = \case + CounterAudited amount -> Just (amount, ()) + CounterAdded {} -> Nothing, + wcBuild = \case + (amount, ()) -> CounterAudited amount + } + +counterCodec :: Codec CounterEvent +counterCodec = + Codec + { eventTypes = EventType "CounterAdded" :| [EventType "CounterAudited"], + eventType = \case + CounterAdded {} -> EventType "CounterAdded" + CounterAudited {} -> EventType "CounterAudited", + schemaVersion = 1, + encode = \case + CounterAdded amount -> object ["amount" Aeson..= amount] + CounterAudited amount -> object ["amount" Aeson..= amount, "audited" Aeson..= True], + decode = parseCounterEvent, + upcasters = [] + } + +parseCounterEvent :: EventType -> Value -> Either Text CounterEvent +parseCounterEvent (EventType tag) value = + case parseEither parser value of + Right event -> Right event + Left message -> Left (fromStringLiteral message) + where + parser = withObject "CounterEvent" $ \objectValue -> do + amount <- objectValue .: "amount" + case tag of + "CounterAdded" -> pure (CounterAdded amount) + "CounterAudited" -> pure (CounterAudited amount) + _ -> fail "unknown counter event type" + +-- * Divert fixture (plan 143: replay-only transitions / black-acuity) ----- + +type DivertEventStream = EventStream (HsPred '[] DivertCommand) '[] DivertState DivertCommand DivertEvent + +type ValidatedDivertEventStream = ValidatedEventStream (HsPred '[] DivertCommand) '[] DivertState DivertCommand DivertEvent + +data DivertCommand + = ConfirmDivert !Bool + deriving stock (Generic, Eq, Show) + +newtype DivertEvent + = DivertConfirmed Bool + deriving stock (Generic, Eq, Show) + +data DivertState + = DivertHeld + deriving stock (Generic, Eq, Show, Enum, Bounded, Ord) + +type DivertFields = '[ '("acuityBlack", Bool)] + +confirmDivertCtor :: InCtor DivertCommand DivertFields +confirmDivertCtor = + InCtor + { icName = "ConfirmDivert", + icMatch = \case + ConfirmDivert acuityBlack -> Just (RCons Proxy acuityBlack RNil), + icBuild = \case + RCons _ acuityBlack RNil -> ConfirmDivert acuityBlack + } + +divertConfirmedCtor :: WireCtor DivertEvent (Bool, ()) +divertConfirmedCtor = + WireCtor + { wcName = "DivertConfirmed", + wcMatch = \case + DivertConfirmed acuityBlack -> Just (acuityBlack, ()), + wcBuild = \case + (acuityBlack, ()) -> DivertConfirmed acuityBlack + } + +divertCodec :: Codec DivertEvent +divertCodec = + Codec + { eventTypes = EventType "DivertConfirmed" :| [], + eventType = \_ -> EventType "DivertConfirmed", + schemaVersion = 1, + encode = \case + DivertConfirmed acuityBlack -> object ["acuityBlack" Aeson..= acuityBlack], + decode = parseDivertEvent, + upcasters = [] + } + +parseDivertEvent :: EventType -> Value -> Either Text DivertEvent +parseDivertEvent _ value = + case parseEither parser value of + Right event -> Right event + Left message -> Left (fromStringLiteral message) + where + parser = withObject "DivertConfirmed" $ \objectValue -> + DivertConfirmed <$> objectValue .: "acuityBlack" + +-- | The old rule: confirm any reservation. +divertOldGuard :: HsPred '[] DivertCommand +divertOldGuard = matchInCtor confirmDivertCtor + +-- | The tightened rule: confirm only non-black acuity. +divertNewGuard :: HsPred '[] DivertCommand +divertNewGuard = + PAnd + (matchInCtor confirmDivertCtor) + (inpCtor confirmDivertCtor #acuityBlack .== Keiki.lit False) + +-- | The removed region, @old ∧ ¬new@: exactly black acuity. +divertRemovedRegionGuard :: HsPred '[] DivertCommand +divertRemovedRegionGuard = + PAnd + (matchInCtor confirmDivertCtor) + (inpCtor confirmDivertCtor #acuityBlack .== Keiki.lit True) + +divertConfirmEdge :: + HsPred '[] DivertCommand -> + Keiki.EdgeMode -> + Edge (HsPred '[] DivertCommand) '[] DivertCommand DivertEvent DivertState +divertConfirmEdge edgeGuard edgeMode = + Edge + { guard = edgeGuard, + update = UKeep, + output = [pack confirmDivertCtor divertConfirmedCtor (inpCtor confirmDivertCtor #acuityBlack *: oNil)], + target = DivertHeld, + mode = edgeMode + } + +divertEventStreamDef :: + [Edge (HsPred '[] DivertCommand) '[] DivertCommand DivertEvent DivertState] -> + DivertEventStream +divertEventStreamDef heldEdges = + EventStream + { transducer = + SymTransducer + { edgesOut = \case + DivertHeld -> heldEdges, + initial = DivertHeld, + initialRegs = RNil, + isFinal = const False + }, + initialState = DivertHeld, + initialRegisters = RNil, + eventCodec = divertCodec, + resolveStreamName = Stream.streamName, + snapshotPolicy = Never, + stateCodec = Nothing + } + +-- | Machine A: the original permissive rule. +permissiveDivertEventStream :: ValidatedDivertEventStream +permissiveDivertEventStream = + mkEventStreamOrThrow + "divert-permissive" + (divertEventStreamDef [divertConfirmEdge divertOldGuard Keiki.Live]) + +-- | Machine B without the twin: the tightened rule alone. +tightenedDivertEventStream :: ValidatedDivertEventStream +tightenedDivertEventStream = + mkEventStreamOrThrow + "divert-tightened" + (divertEventStreamDef [divertConfirmEdge divertNewGuard Keiki.Live]) + +-- | Machine B with the replay-only twin carrying the removed region: +-- the tightened rule governs new traffic; black-acuity history keeps +-- its inverting edge. +twinDivertEventStream :: ValidatedDivertEventStream +twinDivertEventStream = + mkEventStreamOrThrow + "divert-twin" + ( divertEventStreamDef + [ divertConfirmEdge divertNewGuard Keiki.Live, + divertConfirmEdge divertRemovedRegionGuard Keiki.ReplayOnly + ] + ) + +counterProcessManager :: + ProcessManager + CounterEvent + (HsPred '[] CounterCommand) + '[] + CounterState + CounterCommand + CounterEvent + (HsPred '[] CounterCommand) + '[] + CounterState + CounterCommand + CounterEvent +counterProcessManager = + ProcessManager + { name = "counter-pm", + correlate = \_ -> "order-1", + eventStream = counterEventStream, + streamFor = \correlationId -> stream ("pm:counter-" <> correlationId), + targetEventStream = counterEventStream, + targetProjections = const [], + handle = \case + CounterAdded amount -> + ProcessManagerAction + { command = Add amount, + commands = + [ PMCommand + { target = stream "counter-target-order-1", + command = Add amount + } + ], + timers = [counterTimerRequest] + } + CounterAudited amount -> + ProcessManagerAction + { command = Add amount, + commands = [], + timers = [] + } + } + +timerOnlyProcessManager :: + ProcessManager + CounterEvent + (HsPred '[] CounterCommand) + '[] + CounterState + CounterCommand + CounterEvent + (HsPred '[] CounterCommand) + '[] + CounterState + CounterCommand + CounterEvent +timerOnlyProcessManager = + ProcessManager + { name = "timer-only-pm", + correlate = \_ -> "order-1", + eventStream = noOpCounterEventStream, + streamFor = \correlationId -> stream ("pm:timer-only-" <> correlationId), + targetEventStream = counterEventStream, + targetProjections = const [], + handle = \case + CounterAdded amount -> + ProcessManagerAction + { command = Add amount, + commands = [], + timers = + [ counterTimerRequest + & #processManagerName + .~ "timer-only-pm" + ] + } + CounterAudited amount -> + ProcessManagerAction + { command = Add amount, + commands = [], + timers = [] + } + } + +-- A process manager whose OWN state stream snapshots under Every 2. +-- This is the first PM fixture to exercise a state-stream snapshot: the only +-- difference from counterProcessManager is that its eventStream carries a +-- snapshotPolicy + stateCodec (it reuses snapshotCounterEventStream), so +-- runProcessManagerOnce's manager-state append (which goes through +-- runCommandWithSql) writes and reuses snapshots. The manager registers are +-- SnapshotCounterRegs because the eventStream is a SnapshotCounterEventStream; +-- the target side stays '[]/counterEventStream exactly as counterProcessManager. +pmSnapshotCounterEventStreamDef :: SnapshotCounterEventStream +pmSnapshotCounterEventStreamDef = snapshotCounterEventStreamDef + +pmSnapshotCounterEventStream :: ValidatedSnapshotCounterEventStream +pmSnapshotCounterEventStream = mkEventStreamOrThrow "pm-snapshot-counter" pmSnapshotCounterEventStreamDef + +pmSnapshotProcessManager :: + ProcessManager + CounterEvent + (HsPred SnapshotCounterRegs CounterCommand) + SnapshotCounterRegs + CounterState + CounterCommand + CounterEvent + (HsPred '[] CounterCommand) + '[] + CounterState + CounterCommand + CounterEvent +pmSnapshotProcessManager = + ProcessManager + { name = "counter-snap-pm", + correlate = \_ -> "order-1", + eventStream = pmSnapshotCounterEventStream, + streamFor = \correlationId -> stream ("pm:counter-snap-" <> correlationId), + targetEventStream = counterEventStream, + targetProjections = const [], + handle = \case + CounterAdded amount -> + ProcessManagerAction + { command = Add amount, + commands = [], -- keep the test focused on the manager state stream + timers = [] + } + CounterAudited amount -> + ProcessManagerAction + { command = Add amount, + commands = [], + timers = [] + } + } + +workflowProcessManager :: + Text -> + Text -> + Text -> + ProcessManager + CounterEvent + (HsPred '[] CounterCommand) + '[] + CounterState + CounterCommand + CounterEvent + (HsPred '[] CounterCommand) + '[] + CounterState + CounterCommand + CounterEvent +workflowProcessManager managerName managerCategory targetStreamName = + counterProcessManager + { name = managerName, + streamFor = \correlationId -> stream (managerCategory <> "-" <> correlationId), + handle = \case + CounterAdded amount -> + ProcessManagerAction + { command = Add amount, + commands = + [ PMCommand + { target = stream targetStreamName, + command = Add amount + } + ], + timers = [] + } + CounterAudited amount -> + ProcessManagerAction + { command = Add amount, + commands = [], + timers = [] + } + } + +assertWorkflowProcessManagerAppended :: + Either + Store.StoreError + ( Either + CommandError + (ProcessManagerResult CounterEventStream CounterEventStream) + ) -> + Expectation +assertWorkflowProcessManagerAppended = \case + Right (Right pmResult) -> do + pmResult ^. #managerResult `shouldSatisfy` \case + PMStateAppended {} -> True + _ -> False + pmResult ^. #commandResults `shouldSatisfy` \case + [PMCommandAppended {}] -> True + _ -> False + other -> expectationFailure ("expected workflow process-manager success, got " <> show other) + +counterTimerRequest :: TimerRequest +counterTimerRequest = + TimerRequest + { timerId = TimerId sampleUuid, + processManagerName = "counter-pm", + correlationId = "order-1", + fireAt = dueTimerTime, + payload = object ["kind" Aeson..= ("counter-timeout" :: Text)] + } + +dueTimerTime :: UTCTime +dueTimerTime = UTCTime (ModifiedJulianDay 1) (secondsToDiffTime 0) + +timerStatusAndErrorStmt :: Statement UUID (Maybe (Text, Maybe Text)) +timerStatusAndErrorStmt = + preparable + """ + SELECT status, last_error + FROM keiro.keiro_timers + WHERE timer_id = $1 + """ + (E.param (E.nonNullable E.uuid)) + (D.rowMaybe ((,) <$> D.column (D.nonNullable D.text) <*> D.column (D.nullable D.text))) + +-- | Read a timer's status and JSON payload by id (for the workflow-sleep tests). +sleepTimerStatusStmt :: Statement UUID (Maybe (Text, Value)) +sleepTimerStatusStmt = + preparable + """ + SELECT status, payload + FROM keiro.keiro_timers + WHERE timer_id = $1 + """ + (E.param (E.nonNullable E.uuid)) + (D.rowMaybe ((,) <$> D.column (D.nonNullable D.text) <*> D.column (D.nonNullable D.jsonb))) + +-- | Read a timer's fire time by id (for workflow-sleep re-arm tests). +sleepTimerFireAtStmt :: Statement UUID (Maybe UTCTime) +sleepTimerFireAtStmt = + preparable + """ + SELECT fire_at + FROM keiro.keiro_timers + WHERE timer_id = $1 + """ + (E.param (E.nonNullable E.uuid)) + (D.rowMaybe (D.column (D.nonNullable D.timestamptz))) + +recordedFrom :: EventData -> RecordedEvent +recordedFrom event = + RecordedEvent + { eventId = EventId sampleUuid, + eventType = event ^. #eventType, + streamVersion = StreamVersion 1, + globalPosition = GlobalPosition 1, + originalStreamId = StreamId 1, + originalVersion = StreamVersion 1, + payload = event ^. #payload, + metadata = event ^. #metadata, + causationId = Nothing, + correlationId = Nothing, + createdAt = UTCTime (ModifiedJulianDay 0) (secondsToDiffTime 0) + } + +recordedFromEventId :: EventId -> CounterEvent -> RecordedEvent +recordedFromEventId eventId event = + case encodeForAppend counterCodec event of + Right encoded -> recordedFrom encoded & #eventId .~ eventId + Left err -> error ("test fixture failed to encode counter event: " <> show err) + +appendCounterEventWithId :: Store.KirokuStore -> StreamName -> EventId -> CounterEvent -> IO () +appendCounterEventWithId storeHandle streamName eventId event = do + encoded <- shouldBeRight (encodeForAppend counterCodec event) + outcome <- + Store.runStoreIO storeHandle $ + Store.appendToStream streamName NoStream [encoded & #eventId ?~ eventId] + case outcome of + Right _ -> pure () + Left err -> expectationFailure ("failed to insert concurrent duplicate event: " <> show err) + +appendCounterEvents :: Store.KirokuStore -> StreamName -> [CounterEvent] -> IO () +appendCounterEvents storeHandle destinationStreamName events = do + encoded <- traverse (shouldBeRight . encodeForAppend counterCodec) events + outcome <- + Store.runStoreIO storeHandle $ + Store.appendToStream destinationStreamName NoStream encoded + case outcome of + Right _ -> pure () + Left err -> expectationFailure ("failed to insert counter events: " <> show err) + +-- Insert a real source event and drive Kiroku's acknowledgement bridge to park +-- it in kiroku.dead_letters. A second event lets the test observe that the +-- checkpoint advanced after the dead letter before stopping the subscription. +deadLetterCounterSource :: Store.KirokuStore -> SubscriptionName -> CounterEvent -> IO RecordedEvent +deadLetterCounterSource storeHandle subName sourceEvent = do + appendCounterEvents + storeHandle + (StreamName "counter-replay-source") + [sourceEvent, CounterAdded 0] + let subConfig = + ( KirokuSub.defaultSubscriptionConfig + subName + AllStreams + (\_ -> pure KirokuSub.Continue) + ) + { KirokuSub.retryPolicy = KirokuSub.RetryPolicy 1 + } + pull label source = do + result <- timeout 5_000_000 (Streamly.uncons source) + case result of + Just (Just itemAndRest) -> pure itemAndRest + Just Nothing -> fail (label <> ": subscription ended early") + Nothing -> fail (label <> ": timed out waiting for delivery") + (stream0, cancelStream) <- subscriptionAckStream storeHandle subConfig 4 + ( do + (first, stream1) <- pull "source delivery" stream0 + atomically $ + putTMVar + (ackReply first) + (KirokuSub.Retry (KirokuSub.RetryDelay 0)) + (next, stream2) <- pull "event after source dead letter" stream1 + ackEvent next ^. #eventId `shouldNotBe` ackEvent first ^. #eventId + atomically (putTMVar (ackReply next) KirokuSub.Stop) + ended <- timeout 5_000_000 (Streamly.uncons stream2) + case ended of + Just Nothing -> pure () + Just (Just _) -> expectationFailure "replay fixture delivered after Stop" + Nothing -> expectationFailure "replay fixture did not stop" + pure (ackEvent first) + ) + `finally` cancelStream + +classifyProcessManagerReplay :: ProcessManagerResult managerTarget commandTarget -> ReplayResult +classifyProcessManagerReplay result = + case result ^. #managerResult of + PMStateDuplicate {} + | Prelude.all commandIsDuplicate (result ^. #commandResults) -> ReplayedDuplicate + _ -> ReplayedFresh + where + commandIsDuplicate = \case + PMCommandDuplicate {} -> True + _ -> False + +processManagerReplayCounts :: Store.KirokuStore -> IO (Int, Int) +processManagerReplayCounts storeHandle = do + Right managerEvents <- + Store.runStoreIO storeHandle $ + Store.readStreamForward (StreamName "pm:counter-order-1") (StreamVersion 0) 10 + Right targetEvents <- + Store.runStoreIO storeHandle $ + Store.readStreamForward (StreamName "counter-target-order-1") (StreamVersion 0) 10 + pure (Vector.length managerEvents, Vector.length targetEvents) + +sampleUuid :: UUID +sampleUuid = + case fromString "018f0f18-17aa-7000-8000-000000000001" of + Just uuid -> uuid + Nothing -> error "invalid test UUID" + +sampleUuid2 :: UUID +sampleUuid2 = + case fromString "018f0f18-17aa-7000-8000-000000000002" of + Just uuid -> uuid + Nothing -> error "invalid test UUID" + +sampleUuid3 :: UUID +sampleUuid3 = + case fromString "018f0f18-17aa-7000-8000-000000000003" of + Just uuid -> uuid + Nothing -> error "invalid test UUID" + +shouldBeRight :: (HasCallStack, Show e) => Either e a -> IO a +shouldBeRight = \case + Right value -> pure value + Left err -> expectationFailure ("expected Right, got Left " <> show err) *> error "unreachable" + +shouldBeRight_ :: (HasCallStack, Show e) => Either e a -> Expectation +shouldBeRight_ = \case + Right _ -> pure () + Left err -> expectationFailure ("expected Right, got Left " <> show err) + +shouldBeLeft :: (HasCallStack, Eq e, Show e) => Either e a -> e -> Expectation +shouldBeLeft actual expected = + case actual of + Left err -> err `shouldBe` expected + Right _ -> expectationFailure ("expected Left " <> show expected <> ", got Right") + +fromStringLiteral :: String -> Text +fromStringLiteral = Text.pack + +snapshotVersionForStreamStmt :: Statement Text (Maybe StreamVersion) +snapshotVersionForStreamStmt = + preparable + """ + SELECT ks.stream_version + FROM keiro.keiro_snapshots ks + JOIN streams s ON s.stream_id = ks.stream_id + WHERE s.stream_name = $1 + """ + (E.param (E.nonNullable E.text)) + (D.rowMaybe (StreamVersion <$> D.column (D.nonNullable D.int8))) + +snapshotStateShapeForStreamStmt :: Statement Text (Maybe Text) +snapshotStateShapeForStreamStmt = + preparable + """ + SELECT ks.state_shape_hash + FROM keiro.keiro_snapshots ks + JOIN streams s ON s.stream_id = ks.stream_id + WHERE s.stream_name = $1 + """ + (E.param (E.nonNullable E.text)) + (D.rowMaybe (D.column (D.nonNullable D.text))) + +corruptSnapshotStateStmt :: Statement (Text, Value) () +corruptSnapshotStateStmt = + preparable + """ + UPDATE keiro.keiro_snapshots ks + SET state = $2 + FROM streams s + WHERE s.stream_id = ks.stream_id + AND s.stream_name = $1 + """ + ( contrazip2 + (E.param (E.nonNullable E.text)) + (E.param (E.nonNullable E.jsonb)) + ) + D.noResult + +corruptSnapshotShapeStmt :: Statement (Text, Text) () +corruptSnapshotShapeStmt = + preparable + """ + UPDATE keiro.keiro_snapshots ks + SET regfile_shape_hash = $2 + FROM streams s + WHERE s.stream_id = ks.stream_id + AND s.stream_name = $1 + """ + ( contrazip2 + (E.param (E.nonNullable E.text)) + (E.param (E.nonNullable E.text)) + ) + D.noResult + +counterReadModel :: ReadModel Text Int +counterReadModel = + ReadModel + { name = "counter-read-model", + tableName = "counter_read_model", + schema = "kiroku", + subscriptionName = "counter-read-model-sub", + version = 1, + shapeHash = "counter-read-model-v1", + defaultConsistency = Eventual, + strongScope = EntireLog, + query = \modelId -> Tx.statement modelId selectCounterReadModelStmt + } + +counterCategoryReadModel :: ReadModel Text Int +counterCategoryReadModel = + counterReadModel & #strongScope .~ CategoryHead "counter" + +registerReadModelDefinition :: (Store :> es) => ReadModel q r -> Eff es () +registerReadModelDefinition readModel = + void $ + registerReadModel + (readModel ^. #name) + (readModel ^. #version) + (readModel ^. #shapeHash) + +initializeRegisteredReadModel :: + (Store :> es) => + ReadModel q r -> + Tx.Transaction () -> + Eff es () +initializeRegisteredReadModel readModel initializeTable = do + Store.runTransaction initializeTable + registerReadModelDefinition readModel + +counterInlineProjection :: InlineProjection CounterEvent +counterInlineProjection = + InlineProjection + { name = "counter-inline-projection", + apply = \event recorded -> + case event of + CounterAdded amount -> + Tx.statement + ( "inline", + Prelude.fromIntegral amount, + globalPositionToInt (recorded ^. #globalPosition), + Just (eventIdToUuid (recorded ^. #eventId)), + metadataActor recorded + ) + upsertCounterReadModelStmt + CounterAudited {} -> pure () + } + +counterAsyncProjection :: AsyncProjection +counterAsyncProjection = + AsyncProjection + { name = "counter-async-projection", + readModelName = "counter-read-model", + subscriptionName = "counter-read-model-sub", + applyRecorded = \recorded -> + case decodeRecorded counterCodec recorded of + Right (CounterAdded amount) -> + Tx.statement + ( "async-idempotent", + Prelude.fromIntegral amount, + globalPositionToInt (recorded ^. #globalPosition), + Just (eventIdToUuid (recorded ^. #eventId)), + Nothing + ) + upsertCounterReadModelStmt + Right CounterAudited {} -> pure () + Left _ -> pure (), + idempotencyKey = \recorded -> recorded ^. #eventId + } + +fastWaitOptions :: PositionWaitOptions +fastWaitOptions = + PositionWaitOptions + { target = Nothing, + timeoutMicros = 50000, + pollMicros = 5000 + } + +initializeCounterReadModelTable :: Tx.Transaction () +initializeCounterReadModelTable = + Tx.sql + """ + CREATE TABLE IF NOT EXISTS counter_read_model ( + model_id TEXT PRIMARY KEY, + amount BIGINT NOT NULL, + last_seen BIGINT NOT NULL, + source_event_id UUID UNIQUE, + actor TEXT + ) + """ + +-- A read model whose data table lives in an application-configured schema +-- (@app_reads@), demonstrating EP-4's configurable projection schema. Its SQL is +-- fully qualified via 'placedTable'; Keiro's own metadata stays in @keiro@. +placedTable :: Text +placedTable = qualifyTable "app_reads" "placed_counter" + +placedReadModel :: ReadModel Text Int +placedReadModel = + ReadModel + { name = "placed-counter-read-model", + tableName = "placed_counter", + schema = "app_reads", + subscriptionName = "placed-counter-sub", + version = 1, + shapeHash = "placed-counter-v1", + defaultConsistency = Eventual, + strongScope = EntireLog, + query = \modelId -> Tx.statement modelId selectPlacedStmt + } + +placedInlineProjection :: InlineProjection CounterEvent +placedInlineProjection = + InlineProjection + { name = "placed-inline-projection", + apply = \event recorded -> + case event of + CounterAdded amount -> + Tx.statement + ( "placed", + Prelude.fromIntegral amount, + globalPositionToInt (recorded ^. #globalPosition) + ) + upsertPlacedStmt + CounterAudited {} -> pure () + } + +initializePlacedTable :: Tx.Transaction () +initializePlacedTable = + Tx.sql $ + TE.encodeUtf8 $ + "CREATE TABLE IF NOT EXISTS " + <> placedTable + <> " (\n" + <> " model_id TEXT PRIMARY KEY,\n" + <> " amount BIGINT NOT NULL,\n" + <> " last_seen BIGINT NOT NULL\n" + <> ")" + +upsertPlacedStmt :: Statement (Text, Int64, Int64) () +upsertPlacedStmt = + preparable + ( "INSERT INTO " + <> placedTable + <> " (model_id, amount, last_seen)\n" + <> "VALUES ($1, $2, $3)\n" + <> "ON CONFLICT (model_id) DO UPDATE\n" + <> " SET amount = EXCLUDED.amount, last_seen = EXCLUDED.last_seen" + ) + ( contrazip3 + (E.param (E.nonNullable E.text)) + (E.param (E.nonNullable E.int8)) + (E.param (E.nonNullable E.int8)) + ) + D.noResult + +selectPlacedStmt :: Statement Text Int +selectPlacedStmt = + preparable + ("SELECT COALESCE((SELECT amount FROM " <> placedTable <> " WHERE model_id = $1), 0)") + (E.param (E.nonNullable E.text)) + (D.singleRow (Prelude.fromIntegral <$> D.column (D.nonNullable D.int8))) + +-- Count matching base tables in a given schema; proves table placement. +pgTableCountStmt :: Statement (Text, Text) Int +pgTableCountStmt = + preparable + "SELECT count(*)::int FROM pg_tables WHERE schemaname = $1 AND tablename = $2" + ( contrazip2 + (E.param (E.nonNullable E.text)) + (E.param (E.nonNullable E.text)) + ) + (D.singleRow (Prelude.fromIntegral <$> D.column (D.nonNullable D.int4))) + +initializeProjectionDedupCounterTable :: Tx.Transaction () +initializeProjectionDedupCounterTable = + Tx.sql + """ + CREATE TABLE IF NOT EXISTS projection_dedup_counter ( + id BOOLEAN PRIMARY KEY DEFAULT TRUE, + amount BIGINT NOT NULL + ); + + INSERT INTO projection_dedup_counter (id, amount) + VALUES (TRUE, 0) + ON CONFLICT (id) DO NOTHING; + """ + +upsertCounterReadModelStmt :: Statement (Text, Int64, Int64, Maybe UUID, Maybe Text) () +upsertCounterReadModelStmt = + preparable + """ + INSERT INTO counter_read_model (model_id, amount, last_seen, source_event_id, actor) + VALUES ($1, $2, $3, $4, $5) + ON CONFLICT (source_event_id) DO NOTHING + """ + ( contrazip5 + (E.param (E.nonNullable E.text)) + (E.param (E.nonNullable E.int8)) + (E.param (E.nonNullable E.int8)) + (E.param (E.nullable E.uuid)) + (E.param (E.nullable E.text)) + ) + D.noResult + +incrementProjectionDedupCounterStmt :: Statement () () +incrementProjectionDedupCounterStmt = + preparable + """ + UPDATE projection_dedup_counter + SET amount = amount + 1 + WHERE id = TRUE + """ + E.noParams + D.noResult + +selectProjectionDedupCounterStmt :: Statement () Int +selectProjectionDedupCounterStmt = + preparable + """ + SELECT amount + FROM projection_dedup_counter + WHERE id = TRUE + """ + E.noParams + (D.singleRow (Prelude.fromIntegral <$> D.column (D.nonNullable D.int8))) + +projectionDedupCountStmt :: Statement Text Int64 +projectionDedupCountStmt = + preparable + """ + SELECT count(*) + FROM keiro.keiro_projection_dedup + WHERE projection_name = $1 + """ + (E.param (E.nonNullable E.text)) + (D.singleRow (D.column (D.nonNullable D.int8))) + +selectCounterMetaStmt :: Statement Text (Int64, Maybe Text, Maybe UUID) +selectCounterMetaStmt = + preparable + """ + SELECT amount, actor, source_event_id + FROM counter_read_model + WHERE model_id = $1 + """ + (E.param (E.nonNullable E.text)) + ( D.singleRow + ( (,,) + <$> D.column (D.nonNullable D.int8) + <*> D.column (D.nullable D.text) + <*> D.column (D.nullable D.uuid) + ) + ) + +selectCounterReadModelStmt :: Statement Text Int +selectCounterReadModelStmt = + preparable + """ + SELECT COALESCE((SELECT amount FROM counter_read_model WHERE model_id = $1), 0) + """ + (E.param (E.nonNullable E.text)) + (D.singleRow (Prelude.fromIntegral <$> D.column (D.nonNullable D.int8))) + +upsertSubscriptionCursorStmt :: Statement (Text, Int64) () +upsertSubscriptionCursorStmt = + preparable + """ + INSERT INTO subscriptions (subscription_name, stream_name, last_seen) + VALUES ($1, '$all', $2) + ON CONFLICT (subscription_name, consumer_group_member) DO UPDATE + SET last_seen = EXCLUDED.last_seen, + updated_at = now() + """ + ( contrazip2 + (E.param (E.nonNullable E.text)) + (E.param (E.nonNullable E.int8)) + ) + D.noResult + +upsertSubscriptionCursorMemberStmt :: Statement (Text, Int32, Int64) () +upsertSubscriptionCursorMemberStmt = + preparable + """ + INSERT INTO subscriptions (subscription_name, stream_name, consumer_group_member, consumer_group_size, last_seen) + VALUES ($1, '$all', $2, 2, $3) + ON CONFLICT (subscription_name, consumer_group_member) DO UPDATE + SET last_seen = EXCLUDED.last_seen, + updated_at = now() + """ + ( contrazip3 + (E.param (E.nonNullable E.text)) + (E.param (E.nonNullable E.int4)) + (E.param (E.nonNullable E.int8)) + ) + D.noResult + +updateReadModelVersionStmt :: Statement (Text, Int64) () +updateReadModelVersionStmt = + preparable + """ + UPDATE keiro.keiro_read_models + SET version = $2 + WHERE name = $1 + """ + ( contrazip2 + (E.param (E.nonNullable E.text)) + (E.param (E.nonNullable E.int8)) + ) + D.noResult + +updateReadModelStatusStmt :: Statement (Text, Text) () +updateReadModelStatusStmt = + preparable + """ + UPDATE keiro.keiro_read_models + SET status = $2 + WHERE name = $1 + """ + ( contrazip2 + (E.param (E.nonNullable E.text)) + (E.param (E.nonNullable E.text)) + ) + D.noResult + +readModelXminStmt :: Statement Text Text +readModelXminStmt = + preparable + """ + SELECT xmin::text + FROM keiro.keiro_read_models + WHERE name = $1 + """ + (E.param (E.nonNullable E.text)) + (D.singleRow (D.column (D.nonNullable D.text))) + +globalPositionToInt :: GlobalPosition -> Int64 +globalPositionToInt (GlobalPosition value) = value + +eventIdToUuid :: EventId -> UUID +eventIdToUuid (EventId value) = value + +metadataActor :: RecordedEvent -> Maybe Text +metadataActor recorded = do + Aeson.Object o <- recorded ^. #metadata + Aeson.String s <- KeyMap.lookup "actor" o + pure s + +-- Router test fixtures: an effectful, data-dependent fan-out whose target set +-- is stored in a read-model table (router_targets) rather than computed purely. + +newtype RouteGroup = RouteGroup Text + deriving stock (Generic, Eq, Show) + +-- | Maps a routing group to the list of target counter stream identifiers seeded +-- for it. The query is genuinely effectful: 'demoRouter' calls it via 'runQuery'. +routerTargetsReadModel :: ReadModel Text [Text] +routerTargetsReadModel = + ReadModel + { name = "router-targets-read-model", + tableName = "router_targets", + schema = "kiroku", + subscriptionName = "router-targets-sub", + version = 1, + shapeHash = "router-targets-v1", + defaultConsistency = Eventual, + strongScope = EntireLog, + query = \groupId -> Tx.statement groupId selectRouterTargetsStmt + } + +demoRouter :: + (IOE :> es, Store :> es) => + Router + RouteGroup + (HsPred '[] CounterCommand) + '[] + CounterState + CounterCommand + CounterEvent + es +demoRouter = + Router + { name = "demo-router", + key = \(RouteGroup g) -> g, + resolve = \(RouteGroup g) -> do + result <- runQuery Nothing routerTargetsReadModel g + pure $ case result of + Right targetIds -> + [ PMCommand {target = stream targetId, command = Add 1} + | targetId <- targetIds + ] + Left _ -> [], + targetEventStream = counterEventStream, + targetProjections = const [] + } + +unstableRouter :: + (IOE :> es) => + IORef Int -> + (Int -> [Text]) -> + Router + RouteGroup + (HsPred '[] CounterCommand) + '[] + CounterState + CounterCommand + CounterEvent + es +unstableRouter attemptsRef targetsFor = + Router + { name = "unstable-router", + key = \(RouteGroup g) -> g, + resolve = \_ -> do + attempt <- liftIO (atomicModifyIORef' attemptsRef (\n -> (n + 1, n))) + pure + [ PMCommand {target = stream targetId, command = Add 1} + | targetId <- targetsFor attempt + ], + targetEventStream = counterEventStream, + targetProjections = const [] + } + +isAppended :: PMCommandResult target -> Bool +isAppended = \case + PMCommandAppended {} -> True + _ -> False + +isDuplicate :: PMCommandResult target -> Bool +isDuplicate = \case + PMCommandDuplicate {} -> True + _ -> False + +initializeRouterTargetsTable :: Tx.Transaction () +initializeRouterTargetsTable = + Tx.sql + """ + CREATE TABLE IF NOT EXISTS router_targets ( + group_id TEXT NOT NULL, + target_id TEXT NOT NULL + ) + """ + +insertRouterTargetStmt :: Statement (Text, Text) () +insertRouterTargetStmt = + preparable + """ + INSERT INTO router_targets (group_id, target_id) + VALUES ($1, $2) + """ + ( contrazip2 + (E.param (E.nonNullable E.text)) + (E.param (E.nonNullable E.text)) + ) + D.noResult + +selectRouterTargetsStmt :: Statement Text [Text] +selectRouterTargetsStmt = + preparable + """ + SELECT target_id + FROM router_targets + WHERE group_id = $1 + ORDER BY target_id + """ + (E.param (E.nonNullable E.text)) + (D.rowList (D.column (D.nonNullable D.text))) + +-- Router worker fixtures: an in-memory Shibuya adapter that records every +-- finalized AckDecision, plus a router whose dispatch always fails. + +inMemoryAdapter :: + (IOE :> es) => + IORef [AckDecision] -> + [msg] -> + Adapter es msg +inMemoryAdapter decisionsRef messages = + Adapter + { adapterName = "router-test-adapter", + source = Streamly.fromList (fmap ingest messages), + shutdown = pure () + } + where + ingest message = + Ingested + { envelope = routerTestEnvelope message, + ack = AckHandle (\decision -> liftIO (modifyIORef' decisionsRef (<> [decision]))), + lease = Nothing + } + +routerTestEnvelope :: msg -> Envelope msg +routerTestEnvelope message = + Envelope + { messageId = "router-test-message", + cursor = Nothing, + partition = Nothing, + enqueuedAt = Nothing, + traceContext = Nothing, + headers = Nothing, + attempt = Nothing, + attributes = mempty, + payload = message + } + +-- | A target aggregate with no outgoing edges: every command is rejected +-- (CommandRejected), so a dispatch through it surfaces as PMCommandFailed, +-- driving the worker's AckHalt branch. +rejectingEventStreamDef :: CounterEventStream +rejectingEventStreamDef = + counterEventStreamDef & #transducer .~ rejectingTransducer + +rejectingEventStream :: ValidatedCounterEventStream +rejectingEventStream = mkEventStreamOrThrow "rejecting-counter" rejectingEventStreamDef + +-- | Accept every Add command except amount 9, which exercises a worker that +-- dead-letters one rejected dispatch and then successfully processes the next. +rejectNineEventStream :: ValidatedCounterEventStream +rejectNineEventStream = mkEventStreamOrThrow "reject-nine-counter" rejectNineEventStreamDef + +rejectNineEventStreamDef :: CounterEventStream +rejectNineEventStreamDef = + counterEventStreamDef & #transducer .~ rejectNineTransducer + +rejectNineTransducer :: SymTransducer (HsPred '[] CounterCommand) '[] CounterState CounterCommand CounterEvent +rejectNineTransducer = + SymTransducer + { edgesOut = \case + Counting -> + [ Edge + { guard = + PAnd + (matchInCtor addCtor) + (PNot (inpCtor addCtor #amount .== Keiki.lit 9)), + update = UKeep, + output = [pack addCtor counterAddedCtor (inpCtor addCtor #amount *: oNil)], + target = Counting, + mode = Keiki.Live + } + ], + initial = Counting, + initialRegs = RNil, + isFinal = \_ -> False + } + +rejectingTransducer :: SymTransducer (HsPred '[] CounterCommand) '[] CounterState CounterCommand CounterEvent +rejectingTransducer = + SymTransducer + { edgesOut = \case + Counting -> [], + initial = Counting, + initialRegs = RNil, + isFinal = \_ -> False + } + +failingRouter :: + Router + RouteGroup + (HsPred '[] CounterCommand) + '[] + CounterState + CounterCommand + CounterEvent + es +failingRouter = + Router + { name = "failing-router", + key = \(RouteGroup g) -> g, + resolve = \_ -> pure [PMCommand {target = stream "failing-target", command = Add 1}], + targetEventStream = rejectingEventStream, + targetProjections = const [] + } + +-- Flatten exported counter/gauge points to (instrument name, value). +flattenScalarPoints :: [ResourceMetricsExport] -> [(Text, NumberValue)] +flattenScalarPoints rmes = + [ (name, val) + | rme <- rmes, + scope <- Vector.toList (resourceMetricsScopes rme), + export <- Vector.toList (scopeMetricsExports scope), + (name, val) <- pointsOf export + ] + where + pointsOf (MetricExportSum n _ _ _ _ _ _ pts) = + [(n, sumDataPointValue p) | p <- Vector.toList pts] + pointsOf (MetricExportGauge n _ _ _ _ pts) = + [(n, gaugeDataPointValue p) | p <- Vector.toList pts] + pointsOf _ = [] + +-- Flatten exported histogram points to (instrument name, count, sum). +flattenHistogramPoints :: [ResourceMetricsExport] -> [(Text, Word64, Double)] +flattenHistogramPoints rmes = + [ (n, histogramDataPointCount p, histogramDataPointSum p) + | rme <- rmes, + scope <- Vector.toList (resourceMetricsScopes rme), + export <- Vector.toList (scopeMetricsExports scope), + MetricExportHistogram n _ _ _ _ pts <- [export], + p <- Vector.toList pts + ] + +-- =========================================================================== +-- EP-51 sharded-subscription test helpers +-- =========================================================================== + +-- A test sink the sharded handlers write to: one row per processed event, +-- idempotent on event_id (an at-least-once handler may redeliver during a +-- rebalance). worker_tag identifies which worker process handled it; stream_id +-- is the originating stream (the partition key kiroku hashes on). +createShardSinkSql :: ByteString +createShardSinkSql = + "CREATE TABLE IF NOT EXISTS shard_sink \ + \(event_id uuid PRIMARY KEY, worker_tag int NOT NULL, stream_id bigint NOT NULL)" + +-- Seed @nStreams@ category-@orders@ streams with @perStream@ events each +-- (upsert append, so it is safe to call twice in one test). Returns the total +-- number of events appended. +seedOrders :: Store.KirokuStore -> Int -> Int -> IO Int +seedOrders store nStreams perStream = do + for_ [0 .. nStreams - 1] $ \i -> do + let sname = StreamName ("orders-" <> Text.pack (show i)) + evs = + [ EventData + { eventId = Nothing, + eventType = EventType "OrderPlaced", + payload = object ["n" Aeson..= (j :: Int)], + metadata = Nothing, + causationId = Nothing, + correlationId = Nothing + } + | j <- [0 .. perStream - 1] + ] + Right _ <- Store.runStoreIO store $ Store.appendToStream sname AnyVersion evs + pure () + pure (nStreams * perStream) + +-- A handler for worker @tag@: idempotently record (event_id, tag, stream_id). +sinkHandler :: Store.KirokuStore -> Int32 -> RecordedEvent -> IO () +sinkHandler store tag ev = + void $ + Store.runStoreIO store $ + Store.runTransaction $ + Tx.statement (eventUuid (ev ^. #eventId), tag, streamIdInt (ev ^. #originalStreamId)) insertShardSinkStmt + where + eventUuid (EventId u) = u + streamIdInt (StreamId s) = s + +insertShardSinkStmt :: Statement (UUID, Int32, Int64) () +insertShardSinkStmt = + preparable + "INSERT INTO shard_sink (event_id, worker_tag, stream_id) VALUES ($1, $2, $3) ON CONFLICT (event_id) DO NOTHING" + ( contrazip3 + (E.param (E.nonNullable E.uuid)) + (E.param (E.nonNullable E.int4)) + (E.param (E.nonNullable E.int8)) + ) + D.noResult + +shardSinkCount :: Store.KirokuStore -> IO Int +shardSinkCount store = + either (const 0) id + <$> Store.runStoreIO store (Store.runTransaction (Tx.statement () countShardSinkStmt)) + +countShardSinkStmt :: Statement () Int +countShardSinkStmt = + preparable + "SELECT count(*) FROM shard_sink" + E.noParams + (D.singleRow (fromIntegral <$> D.column (D.nonNullable D.int8))) + +shardDeadLetterDetails :: Store.KirokuStore -> Text -> IO (Int, Maybe Text, Maybe Int) +shardDeadLetterDetails store subscription = + either (const (0, Nothing, Nothing)) id + <$> Store.runStoreIO store (Store.runTransaction (Tx.statement subscription shardDeadLetterDetailsStmt)) + +shardDeadLetterDetailsStmt :: Statement Text (Int, Maybe Text, Maybe Int) +shardDeadLetterDetailsStmt = + preparable + "SELECT count(*)::bigint, max(reason_summary), max(attempt_count) \ + \FROM kiroku.dead_letters \ + \WHERE subscription_name = $1 AND consumer_group_member = 0" + (E.param (E.nonNullable E.text)) + ( D.singleRow $ + (,,) + <$> (fromIntegral <$> D.column (D.nonNullable D.int8)) + <*> D.column (D.nullable D.text) + <*> (fmap fromIntegral <$> D.column (D.nullable D.int4)) + ) + +-- The largest number of distinct workers that processed any single stream. 1 +-- means perfectly disjoint ownership (no stream split across workers). +maxWorkersPerStream :: Store.KirokuStore -> IO Int +maxWorkersPerStream store = + either (const 0) id + <$> Store.runStoreIO store (Store.runTransaction (Tx.statement () maxWorkersPerStreamStmt)) + +maxWorkersPerStreamStmt :: Statement () Int +maxWorkersPerStreamStmt = + preparable + "SELECT COALESCE(MAX(c), 0) FROM \ + \(SELECT count(DISTINCT worker_tag) AS c FROM shard_sink GROUP BY stream_id) s" + E.noParams + (D.singleRow (fromIntegral <$> D.column (D.nonNullable D.int8))) + +-- How many distinct workers processed at least one event (proves the work +-- spread across the pool rather than monopolised by one worker). +distinctWorkers :: Store.KirokuStore -> IO Int +distinctWorkers store = + either (const 0) id + <$> Store.runStoreIO store (Store.runTransaction (Tx.statement () distinctWorkersStmt)) + +distinctWorkersStmt :: Statement () Int +distinctWorkersStmt = + preparable + "SELECT count(DISTINCT worker_tag) FROM shard_sink" + E.noParams + (D.singleRow (fromIntegral <$> D.column (D.nonNullable D.int8))) + +-- Poll the sink count until it reaches @target@ or the timeout elapses. +waitUntilSinkCount :: Store.KirokuStore -> Int -> Int -> IO Bool +waitUntilSinkCount store target timeoutMicros = go (max 1 (timeoutMicros `div` step)) + where + step = 100_000 + go :: Int -> IO Bool + go 0 = (>= target) <$> shardSinkCount store + go n = do + c <- shardSinkCount store + if c >= target + then pure True + else threadDelay step >> go (n - 1) + +-- Poll until at least @target@ shard rows have a live owner. Tests use this to +-- join a second worker at a precise point in the one-bucket-per-pass ramp-up. +waitUntilOwnedShardCount :: Store.KirokuStore -> SubscriptionName -> Int -> Int -> IO Bool +waitUntilOwnedShardCount store sub target timeoutMicros = go (max 1 (timeoutMicros `div` step)) + where + step = 50_000 + go 0 = hasTarget + go n = do + reached <- hasTarget + if reached then pure True else threadDelay step >> go (n - 1) + hasTarget = do + rows <- either (const []) id <$> Store.runStoreIO store (Store.runTransaction (listShardOwnership sub)) + pure (length [() | (_, Just _, _) <- rows] >= target) + +-- Poll the lease table until cooperative ownership has converged: every bucket +-- owned, at least @minWorkers@ distinct owners, and no owner holding more than +-- its fair share. This is the "balanced on the empty category" gate the +-- failover test waits on before seeding, so the drain runs under stable +-- membership. +waitShardsBalanced :: Store.KirokuStore -> SubscriptionName -> Int -> Int -> Int -> IO Bool +waitShardsBalanced store sub n minWorkers timeoutMicros = go (max 1 (timeoutMicros `div` step)) + where + step = 200_000 + go :: Int -> IO Bool + go 0 = isBalanced + go k = do + ok <- isBalanced + if ok then pure True else threadDelay step >> go (k - 1) + isBalanced :: IO Bool + isBalanced = do + rows <- either (const []) id <$> Store.runStoreIO store (Store.runTransaction (listShardOwnership sub)) + let owners = [w | (_, Just w, _) <- rows] + distinct = length (nubOrd owners) + perOwner = [length g | g <- groupByOwner owners] + fairShare = (n + max 1 distinct - 1) `div` max 1 distinct + pure (length rows == n && length owners == n && distinct >= minWorkers && all (<= fairShare) perOwner) + groupByOwner ws = [filter (== w) ws | w <- nubOrd ws] + nubOrd = Set.toList . Set.fromList + +waitShardsUnowned :: Store.KirokuStore -> SubscriptionName -> Int -> Int -> IO Bool +waitShardsUnowned store sub n timeoutMicros = go (max 1 (timeoutMicros `div` step)) + where + step = 100_000 + go 0 = isUnowned + go k = do + ok <- isUnowned + if ok then pure True else threadDelay step >> go (k - 1) + isUnowned = do + rows <- either (const []) id <$> Store.runStoreIO store (Store.runTransaction (listShardOwnership sub)) + pure (length rows == n && all (\(_, owner, _) -> isNothing owner) rows) + +workflowOwnedRowCounts :: (Store :> es) => Text -> Text -> Eff es (Int64, Int64, Int64, Int64, Int64, Int64) +workflowOwnedRowCounts name wid = + Store.runTransaction (Tx.statement (wid, name) workflowOwnedRowCountsStmt) + +workflowOwnedChildCount :: (Store :> es) => Text -> Text -> Eff es Int64 +workflowOwnedChildCount name wid = + Store.runTransaction (Tx.statement (wid, name, wid, name) workflowOwnedChildCountStmt) + +workflowWakeAfter :: (Store :> es) => WorkflowName -> WorkflowId -> Eff es (Maybe UTCTime) +workflowWakeAfter (WorkflowName name) (WorkflowId wid) = + Store.runTransaction (Tx.statement (wid, name) workflowWakeAfterStmt) + +insertGcTimerStmt :: Statement (UUID, Text, Text, UTCTime, Value, Text) () +insertGcTimerStmt = + preparable + """ + INSERT INTO keiro.keiro_timers + (timer_id, process_manager_name, correlation_id, fire_at, payload, status) + VALUES ($1, $2, $3, $4, $5, $6) + """ + ( contrazip6 + (E.param (E.nonNullable E.uuid)) + (E.param (E.nonNullable E.text)) + (E.param (E.nonNullable E.text)) + (E.param (E.nonNullable E.timestamptz)) + (E.param (E.nonNullable E.jsonb)) + (E.param (E.nonNullable E.text)) + ) + D.noResult + +deleteGcStepsStmt :: Statement (Text, Text) () +deleteGcStepsStmt = + preparable + """ + DELETE FROM keiro.keiro_workflow_steps + WHERE workflow_id = $1 AND workflow_name = $2 + """ + ( contrazip2 + (E.param (E.nonNullable E.text)) + (E.param (E.nonNullable E.text)) + ) + D.noResult + +deleteWorkflowInstanceStmt :: Statement (Text, Text) () +deleteWorkflowInstanceStmt = + preparable + """ + DELETE FROM keiro.keiro_workflows + WHERE workflow_id = $1 AND workflow_name = $2 + """ + ( contrazip2 + (E.param (E.nonNullable E.text)) + (E.param (E.nonNullable E.text)) + ) + D.noResult + +workflowWakeAfterStmt :: Statement (Text, Text) (Maybe UTCTime) +workflowWakeAfterStmt = + preparable + """ + SELECT wake_after + FROM keiro.keiro_workflows + WHERE workflow_id = $1 AND workflow_name = $2 + """ + ( contrazip2 + (E.param (E.nonNullable E.text)) + (E.param (E.nonNullable E.text)) + ) + (maybe Nothing id <$> D.rowMaybe (D.column (D.nullable D.timestamptz))) + +workflowOwnedRowCountsStmt :: Statement (Text, Text) (Int64, Int64, Int64, Int64, Int64, Int64) +workflowOwnedRowCountsStmt = + preparable + """ + SELECT + (SELECT count(*) FROM keiro.keiro_workflows WHERE workflow_id = $1 AND workflow_name = $2), + (SELECT count(*) FROM keiro.keiro_workflow_steps WHERE workflow_id = $1 AND workflow_name = $2), + (SELECT count(*) FROM keiro.keiro_awakeables WHERE owner_workflow_id = $1 AND owner_workflow_name = $2), + (SELECT count(*) FROM keiro.keiro_workflow_children + WHERE (parent_id = $1 AND parent_name = $2) OR (child_id = $1 AND child_name = $2)), + (SELECT count(*) FROM keiro.keiro_timers + WHERE correlation_id = $1 AND process_manager_name = $2 AND payload->>'kind' = 'keiro.workflow.sleep'), + (SELECT count(*) + FROM keiro.keiro_snapshots s + JOIN streams st ON st.stream_id = s.stream_id + WHERE st.stream_name = 'wf:' || $2 || '-' || $1) + """ + ( contrazip2 + (E.param (E.nonNullable E.text)) + (E.param (E.nonNullable E.text)) + ) + ( D.singleRow $ + (,,,,,) + <$> D.column (D.nonNullable D.int8) + <*> D.column (D.nonNullable D.int8) + <*> D.column (D.nonNullable D.int8) + <*> D.column (D.nonNullable D.int8) + <*> D.column (D.nonNullable D.int8) + <*> D.column (D.nonNullable D.int8) + ) + +workflowOwnedChildCountStmt :: Statement (Text, Text, Text, Text) Int64 +workflowOwnedChildCountStmt = + preparable + """ + SELECT count(*) + FROM keiro.keiro_workflow_children + WHERE (parent_id = $1 AND parent_name = $2) + OR (child_id = $3 AND child_name = $4) + """ + ( contrazip4 + (E.param (E.nonNullable E.text)) + (E.param (E.nonNullable E.text)) + (E.param (E.nonNullable E.text)) + (E.param (E.nonNullable E.text)) + ) + (D.singleRow (D.column (D.nonNullable D.int8)))